diff --git a/.gitignore b/.gitignore index 6840d19..bdd460c 100644 --- a/.gitignore +++ b/.gitignore @@ -28,3 +28,13 @@ log* \.project \.settings/language\.settings\.xml + +utils_src/readprintwc/out + +.kdev4/ + +.vscode/ + +hi.* + +post-scarcity.kdev4 diff --git a/Doxyfile b/Doxyfile index b94ec20..955cb32 100644 --- a/Doxyfile +++ b/Doxyfile @@ -32,13 +32,13 @@ DOXYFILE_ENCODING = UTF-8 # title of most generated pages and in a few other places. # The default value is: My Project. -PROJECT_NAME = "\"Post Scarcity\"" +PROJECT_NAME = "Post Scarcity" # The PROJECT_NUMBER tag can be used to enter a project or revision number. This # could be handy for archiving the generated documentation or if some version # control system is used. -PROJECT_NUMBER = +PROJECT_NUMBER = # Using the PROJECT_BRIEF tag one can provide an optional one line description # for a project that appears at the top of each page and should give viewer a @@ -51,14 +51,14 @@ PROJECT_BRIEF = "A prototype for a post scarcity programming environmen # pixels and the maximum width should not exceed 200 pixels. Doxygen will copy # the logo to the output directory. -PROJECT_LOGO = +PROJECT_LOGO = # The OUTPUT_DIRECTORY tag is used to specify the (relative or absolute) path # into which the generated documentation will be written. If a relative path is # entered, it will be relative to the location where doxygen was started. If # left blank the current directory will be used. -OUTPUT_DIRECTORY = /home/simon/workspace/post-scarcity/doc +OUTPUT_DIRECTORY = doc # If the CREATE_SUBDIRS tag is set to YES then doxygen will create 4096 sub- # directories (in 2 levels) under the output directory of each output format and @@ -162,7 +162,7 @@ FULL_PATH_NAMES = YES # will be relative from the directory where doxygen is started. # This tag requires that the tag FULL_PATH_NAMES is set to YES. -STRIP_FROM_PATH = +STRIP_FROM_PATH = # The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the # path mentioned in the documentation of a class, which tells the reader which @@ -171,7 +171,7 @@ STRIP_FROM_PATH = # specify the list of include paths that are normally passed to the compiler # using the -I flag. -STRIP_FROM_INC_PATH = +STRIP_FROM_INC_PATH = # If the SHORT_NAMES tag is set to YES, doxygen will generate much shorter (but # less readable) file names. This can be useful is your file systems doesn't @@ -238,13 +238,13 @@ TAB_SIZE = 4 # "Side Effects:". You can put \n's in the value part of an alias to insert # newlines. -ALIASES = +ALIASES = # This tag can be used to specify a number of word-keyword mappings (TCL only). # A mapping has the form "name=value". For example adding "class=itcl::class" # will allow you to use the command class in the itcl::class meaning. -TCL_SUBST = +TCL_SUBST = # Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources # only. Doxygen will then generate output that is more tailored for C. For @@ -291,7 +291,7 @@ OPTIMIZE_OUTPUT_VHDL = NO # Note that for custom extensions you also need to set FILE_PATTERNS otherwise # the files are not read by doxygen. -EXTENSION_MAPPING = +EXTENSION_MAPPING = # If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments # according to the Markdown format, which allows for more readable @@ -648,7 +648,7 @@ GENERATE_DEPRECATEDLIST= YES # sections, marked by \if ... \endif and \cond # ... \endcond blocks. -ENABLED_SECTIONS = +ENABLED_SECTIONS = # The MAX_INITIALIZER_LINES tag determines the maximum number of lines that the # initial value of a variable or macro / define can have for it to appear in the @@ -690,7 +690,7 @@ SHOW_NAMESPACES = YES # by doxygen. Whatever the program writes to standard output is used as the file # version. For an example see the documentation. -FILE_VERSION_FILTER = +FILE_VERSION_FILTER = # The LAYOUT_FILE tag can be used to specify a layout file which will be parsed # by doxygen. The layout file controls the global structure of the generated @@ -703,7 +703,7 @@ FILE_VERSION_FILTER = # DoxygenLayout.xml, doxygen will parse it automatically even if the LAYOUT_FILE # tag is left empty. -LAYOUT_FILE = +LAYOUT_FILE = # The CITE_BIB_FILES tag can be used to specify one or more bib files containing # the reference definitions. This must be a list of .bib files. The .bib @@ -713,7 +713,7 @@ LAYOUT_FILE = # LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the # search path. See also \cite for info how to create references. -CITE_BIB_FILES = +CITE_BIB_FILES = #--------------------------------------------------------------------------- # Configuration options related to warning and progress messages @@ -778,7 +778,7 @@ WARN_FORMAT = "$file:$line: $text" # messages should be written. If left blank the output is written to standard # error (stderr). -WARN_LOGFILE = +WARN_LOGFILE = doxy.log #--------------------------------------------------------------------------- # Configuration options related to the input files @@ -790,7 +790,7 @@ WARN_LOGFILE = # spaces. See also FILE_PATTERNS and EXTENSION_MAPPING # Note: If this tag is empty the current directory is searched. -INPUT = /home/simon/workspace/post-scarcity/src +INPUT = src src/arith src/memory src/ops # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses @@ -873,7 +873,7 @@ RECURSIVE = NO # Note that relative paths are relative to the directory from which doxygen is # run. -EXCLUDE = +EXCLUDE = # The EXCLUDE_SYMLINKS tag can be used to select whether or not files or # directories that are symbolic links (a Unix file system feature) are excluded @@ -889,7 +889,7 @@ EXCLUDE_SYMLINKS = NO # Note that the wildcards are matched against the file with absolute path, so to # exclude all test directories for example use the pattern */test/* -EXCLUDE_PATTERNS = +EXCLUDE_PATTERNS = # The EXCLUDE_SYMBOLS tag can be used to specify one or more symbol names # (namespaces, classes, functions, etc.) that should be excluded from the @@ -900,13 +900,13 @@ EXCLUDE_PATTERNS = # Note that the wildcards are matched against the file with absolute path, so to # exclude all test directories use the pattern */test/* -EXCLUDE_SYMBOLS = +EXCLUDE_SYMBOLS = # The EXAMPLE_PATH tag can be used to specify one or more files or directories # that contain example code fragments that are included (see the \include # command). -EXAMPLE_PATH = +EXAMPLE_PATH = # If the value of the EXAMPLE_PATH tag contains directories, you can use the # EXAMPLE_PATTERNS tag to specify one or more wildcard pattern (like *.cpp and @@ -926,7 +926,7 @@ EXAMPLE_RECURSIVE = NO # that contain images that are to be included in the documentation (see the # \image command). -IMAGE_PATH = +IMAGE_PATH = # The INPUT_FILTER tag can be used to specify a program that doxygen should # invoke to filter for each input file. Doxygen will invoke the filter program @@ -947,7 +947,7 @@ IMAGE_PATH = # need to set EXTENSION_MAPPING for the extension otherwise the files are not # properly processed by doxygen. -INPUT_FILTER = +INPUT_FILTER = # The FILTER_PATTERNS tag can be used to specify filters on a per file pattern # basis. Doxygen will compare the file name with each pattern and apply the @@ -960,7 +960,7 @@ INPUT_FILTER = # need to set EXTENSION_MAPPING for the extension otherwise the files are not # properly processed by doxygen. -FILTER_PATTERNS = +FILTER_PATTERNS = # If the FILTER_SOURCE_FILES tag is set to YES, the input filter (if set using # INPUT_FILTER) will also be used to filter the input files that are used for @@ -975,14 +975,14 @@ FILTER_SOURCE_FILES = NO # *.ext= (so without naming a filter). # This tag requires that the tag FILTER_SOURCE_FILES is set to YES. -FILTER_SOURCE_PATTERNS = +FILTER_SOURCE_PATTERNS = # If the USE_MDFILE_AS_MAINPAGE tag refers to the name of a markdown file that # is part of the input, its contents will be placed on the main page # (index.html). This can be useful if you have a project on for instance GitHub # and want to reuse the introduction page also for the doxygen output. -USE_MDFILE_AS_MAINPAGE = +USE_MDFILE_AS_MAINPAGE = #--------------------------------------------------------------------------- # Configuration options related to source browsing @@ -1087,7 +1087,7 @@ CLANG_ASSISTED_PARSING = NO # specified with INPUT and INCLUDE_PATH. # This tag requires that the tag CLANG_ASSISTED_PARSING is set to YES. -CLANG_OPTIONS = +CLANG_OPTIONS = #--------------------------------------------------------------------------- # Configuration options related to the alphabetical class index @@ -1113,7 +1113,7 @@ COLS_IN_ALPHA_INDEX = 5 # while generating the index headers. # This tag requires that the tag ALPHABETICAL_INDEX is set to YES. -IGNORE_PREFIX = +IGNORE_PREFIX = #--------------------------------------------------------------------------- # Configuration options related to the HTML output @@ -1157,7 +1157,7 @@ HTML_FILE_EXTENSION = .html # of the possible markers and block names see the documentation. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_HEADER = +HTML_HEADER = # The HTML_FOOTER tag can be used to specify a user-defined HTML footer for each # generated HTML page. If the tag is left blank doxygen will generate a standard @@ -1167,7 +1167,7 @@ HTML_HEADER = # that doxygen normally uses. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_FOOTER = +HTML_FOOTER = # The HTML_STYLESHEET tag can be used to specify a user-defined cascading style # sheet that is used by each HTML page. It can be used to fine-tune the look of @@ -1179,7 +1179,7 @@ HTML_FOOTER = # obsolete. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_STYLESHEET = +HTML_STYLESHEET = # The HTML_EXTRA_STYLESHEET tag can be used to specify additional user-defined # cascading style sheets that are included after the standard style sheets @@ -1192,7 +1192,7 @@ HTML_STYLESHEET = # list). For an example see the documentation. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_EXTRA_STYLESHEET = +HTML_EXTRA_STYLESHEET = # The HTML_EXTRA_FILES tag can be used to specify one or more extra images or # other source files which should be copied to the HTML output directory. Note @@ -1202,7 +1202,7 @@ HTML_EXTRA_STYLESHEET = # files will be copied as-is; there are no commands or markers available. # This tag requires that the tag GENERATE_HTML is set to YES. -HTML_EXTRA_FILES = +HTML_EXTRA_FILES = # The HTML_COLORSTYLE_HUE tag controls the color of the HTML output. Doxygen # will adjust the colors in the style sheet and background images according to @@ -1331,7 +1331,7 @@ GENERATE_HTMLHELP = NO # written to the html output directory. # This tag requires that the tag GENERATE_HTMLHELP is set to YES. -CHM_FILE = +CHM_FILE = # The HHC_LOCATION tag can be used to specify the location (absolute path # including file name) of the HTML help compiler (hhc.exe). If non-empty, @@ -1339,7 +1339,7 @@ CHM_FILE = # The file has to be specified with full path. # This tag requires that the tag GENERATE_HTMLHELP is set to YES. -HHC_LOCATION = +HHC_LOCATION = # The GENERATE_CHI flag controls if a separate .chi index file is generated # (YES) or that it should be included in the master .chm file (NO). @@ -1352,7 +1352,7 @@ GENERATE_CHI = NO # and project file content. # This tag requires that the tag GENERATE_HTMLHELP is set to YES. -CHM_INDEX_ENCODING = +CHM_INDEX_ENCODING = # The BINARY_TOC flag controls whether a binary table of contents is generated # (YES) or a normal table of contents (NO) in the .chm file. Furthermore it @@ -1383,7 +1383,7 @@ GENERATE_QHP = NO # the HTML output folder. # This tag requires that the tag GENERATE_QHP is set to YES. -QCH_FILE = +QCH_FILE = # The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help # Project output. For more information please see Qt Help Project / Namespace @@ -1408,7 +1408,7 @@ QHP_VIRTUAL_FOLDER = doc # filters). # This tag requires that the tag GENERATE_QHP is set to YES. -QHP_CUST_FILTER_NAME = +QHP_CUST_FILTER_NAME = # The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the # custom filter to add. For more information please see Qt Help Project / Custom @@ -1416,21 +1416,21 @@ QHP_CUST_FILTER_NAME = # filters). # This tag requires that the tag GENERATE_QHP is set to YES. -QHP_CUST_FILTER_ATTRS = +QHP_CUST_FILTER_ATTRS = # The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this # project's filter section matches. Qt Help Project / Filter Attributes (see: # http://qt-project.org/doc/qt-4.8/qthelpproject.html#filter-attributes). # This tag requires that the tag GENERATE_QHP is set to YES. -QHP_SECT_FILTER_ATTRS = +QHP_SECT_FILTER_ATTRS = # The QHG_LOCATION tag can be used to specify the location of Qt's # qhelpgenerator. If non-empty doxygen will try to run qhelpgenerator on the # generated .qhp file. # This tag requires that the tag GENERATE_QHP is set to YES. -QHG_LOCATION = +QHG_LOCATION = # If the GENERATE_ECLIPSEHELP tag is set to YES, additional index files will be # generated, together with the HTML files, they form an Eclipse help plugin. To @@ -1563,7 +1563,7 @@ MATHJAX_RELPATH = http://cdn.mathjax.org/mathjax/latest # MATHJAX_EXTENSIONS = TeX/AMSmath TeX/AMSsymbols # This tag requires that the tag USE_MATHJAX is set to YES. -MATHJAX_EXTENSIONS = +MATHJAX_EXTENSIONS = # The MATHJAX_CODEFILE tag can be used to specify a file with javascript pieces # of code that will be used on startup of the MathJax code. See the MathJax site @@ -1571,7 +1571,7 @@ MATHJAX_EXTENSIONS = # example see the documentation. # This tag requires that the tag USE_MATHJAX is set to YES. -MATHJAX_CODEFILE = +MATHJAX_CODEFILE = # When the SEARCHENGINE tag is enabled doxygen will generate a search box for # the HTML output. The underlying search engine uses javascript and DHTML and @@ -1631,7 +1631,7 @@ EXTERNAL_SEARCH = NO # Searching" for details. # This tag requires that the tag SEARCHENGINE is set to YES. -SEARCHENGINE_URL = +SEARCHENGINE_URL = # When SERVER_BASED_SEARCH and EXTERNAL_SEARCH are both enabled the unindexed # search data is written to a file for indexing by an external tool. With the @@ -1647,7 +1647,7 @@ SEARCHDATA_FILE = searchdata.xml # projects and redirect the results back to the right project. # This tag requires that the tag SEARCHENGINE is set to YES. -EXTERNAL_SEARCH_ID = +EXTERNAL_SEARCH_ID = # The EXTRA_SEARCH_MAPPINGS tag can be used to enable searching through doxygen # projects other than the one defined by this configuration file, but that are @@ -1657,7 +1657,7 @@ EXTERNAL_SEARCH_ID = # EXTRA_SEARCH_MAPPINGS = tagname1=loc1 tagname2=loc2 ... # This tag requires that the tag SEARCHENGINE is set to YES. -EXTRA_SEARCH_MAPPINGS = +EXTRA_SEARCH_MAPPINGS = #--------------------------------------------------------------------------- # Configuration options related to the LaTeX output @@ -1721,7 +1721,7 @@ PAPER_TYPE = a4 # If left blank no extra packages will be included. # This tag requires that the tag GENERATE_LATEX is set to YES. -EXTRA_PACKAGES = +EXTRA_PACKAGES = # The LATEX_HEADER tag can be used to specify a personal LaTeX header for the # generated LaTeX document. The header should contain everything until the first @@ -1737,7 +1737,7 @@ EXTRA_PACKAGES = # to HTML_HEADER. # This tag requires that the tag GENERATE_LATEX is set to YES. -LATEX_HEADER = +LATEX_HEADER = # The LATEX_FOOTER tag can be used to specify a personal LaTeX footer for the # generated LaTeX document. The footer should contain everything after the last @@ -1748,7 +1748,7 @@ LATEX_HEADER = # Note: Only use a user-defined footer if you know what you are doing! # This tag requires that the tag GENERATE_LATEX is set to YES. -LATEX_FOOTER = +LATEX_FOOTER = # The LATEX_EXTRA_STYLESHEET tag can be used to specify additional user-defined # LaTeX style sheets that are included after the standard style sheets created @@ -1759,7 +1759,7 @@ LATEX_FOOTER = # list). # This tag requires that the tag GENERATE_LATEX is set to YES. -LATEX_EXTRA_STYLESHEET = +LATEX_EXTRA_STYLESHEET = # The LATEX_EXTRA_FILES tag can be used to specify one or more extra images or # other source files which should be copied to the LATEX_OUTPUT output @@ -1767,7 +1767,7 @@ LATEX_EXTRA_STYLESHEET = # markers available. # This tag requires that the tag GENERATE_LATEX is set to YES. -LATEX_EXTRA_FILES = +LATEX_EXTRA_FILES = # If the PDF_HYPERLINKS tag is set to YES, the LaTeX that is generated is # prepared for conversion to PDF (using ps2pdf or pdflatex). The PDF file will @@ -1875,14 +1875,14 @@ RTF_HYPERLINKS = NO # default style sheet that doxygen normally uses. # This tag requires that the tag GENERATE_RTF is set to YES. -RTF_STYLESHEET_FILE = +RTF_STYLESHEET_FILE = # Set optional variables used in the generation of an RTF document. Syntax is # similar to doxygen's config file. A template extensions file can be generated # using doxygen -e rtf extensionFile. # This tag requires that the tag GENERATE_RTF is set to YES. -RTF_EXTENSIONS_FILE = +RTF_EXTENSIONS_FILE = # If the RTF_SOURCE_CODE tag is set to YES then doxygen will include source code # with syntax highlighting in the RTF output. @@ -1927,7 +1927,7 @@ MAN_EXTENSION = .3 # MAN_EXTENSION with the initial . removed. # This tag requires that the tag GENERATE_MAN is set to YES. -MAN_SUBDIR = +MAN_SUBDIR = # If the MAN_LINKS tag is set to YES and doxygen generates man output, then it # will generate one additional man file for each entity documented in the real @@ -2040,7 +2040,7 @@ PERLMOD_PRETTY = YES # overwrite each other's variables. # This tag requires that the tag GENERATE_PERLMOD is set to YES. -PERLMOD_MAKEVAR_PREFIX = +PERLMOD_MAKEVAR_PREFIX = #--------------------------------------------------------------------------- # Configuration options related to the preprocessor @@ -2081,7 +2081,7 @@ SEARCH_INCLUDES = YES # preprocessor. # This tag requires that the tag SEARCH_INCLUDES is set to YES. -INCLUDE_PATH = +INCLUDE_PATH = # You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard # patterns (like *.h and *.hpp) to filter out the header-files in the @@ -2089,7 +2089,7 @@ INCLUDE_PATH = # used. # This tag requires that the tag ENABLE_PREPROCESSING is set to YES. -INCLUDE_FILE_PATTERNS = +INCLUDE_FILE_PATTERNS = # The PREDEFINED tag can be used to specify one or more macro names that are # defined before the preprocessor is started (similar to the -D option of e.g. @@ -2099,7 +2099,7 @@ INCLUDE_FILE_PATTERNS = # recursively expanded use the := operator instead of the = operator. # This tag requires that the tag ENABLE_PREPROCESSING is set to YES. -PREDEFINED = +PREDEFINED = # If the MACRO_EXPANSION and EXPAND_ONLY_PREDEF tags are set to YES then this # tag can be used to specify a list of macro names that should be expanded. The @@ -2108,7 +2108,7 @@ PREDEFINED = # definition found in the source code. # This tag requires that the tag ENABLE_PREPROCESSING is set to YES. -EXPAND_AS_DEFINED = +EXPAND_AS_DEFINED = # If the SKIP_FUNCTION_MACROS tag is set to YES then doxygen's preprocessor will # remove all references to function-like macros that are alone on a line, have @@ -2137,13 +2137,13 @@ SKIP_FUNCTION_MACROS = YES # the path). If a tag file is not located in the directory in which doxygen is # run, you must also specify the path to the tagfile here. -TAGFILES = +TAGFILES = # When a file name is specified after GENERATE_TAGFILE, doxygen will create a # tag file that is based on the input files it reads. See section "Linking to # external documentation" for more information about the usage of tag files. -GENERATE_TAGFILE = +GENERATE_TAGFILE = # If the ALLEXTERNALS tag is set to YES, all external class will be listed in # the class index. If set to NO, only the inherited external classes will be @@ -2192,14 +2192,14 @@ CLASS_DIAGRAMS = YES # the mscgen tool resides. If left empty the tool is assumed to be found in the # default search path. -MSCGEN_PATH = +MSCGEN_PATH = # You can include diagrams made with dia in doxygen documentation. Doxygen will # then run dia to produce the diagram and insert it in the documentation. The # DIA_PATH tag allows you to specify the directory where the dia binary resides. # If left empty dia is assumed to be found in the default search path. -DIA_PATH = +DIA_PATH = # If set to YES the inheritance and collaboration graphs will hide inheritance # and usage relations if the target is undocumented or is not a class. @@ -2248,7 +2248,7 @@ DOT_FONTSIZE = 10 # the path where dot can find it using this tag. # This tag requires that the tag HAVE_DOT is set to YES. -DOT_FONTPATH = +DOT_FONTPATH = # If the CLASS_GRAPH tag is set to YES then doxygen will generate a graph for # each documented class showing the direct and indirect inheritance relations. @@ -2394,26 +2394,26 @@ INTERACTIVE_SVG = YES # found. If left blank, it is assumed the dot tool can be found in the path. # This tag requires that the tag HAVE_DOT is set to YES. -DOT_PATH = +DOT_PATH = # The DOTFILE_DIRS tag can be used to specify one or more directories that # contain dot files that are included in the documentation (see the \dotfile # command). # This tag requires that the tag HAVE_DOT is set to YES. -DOTFILE_DIRS = +DOTFILE_DIRS = # The MSCFILE_DIRS tag can be used to specify one or more directories that # contain msc files that are included in the documentation (see the \mscfile # command). -MSCFILE_DIRS = +MSCFILE_DIRS = # The DIAFILE_DIRS tag can be used to specify one or more directories that # contain dia files that are included in the documentation (see the \diafile # command). -DIAFILE_DIRS = +DIAFILE_DIRS = # When using plantuml, the PLANTUML_JAR_PATH tag should be used to specify the # path where java can find the plantuml.jar file. If left blank, it is assumed @@ -2421,17 +2421,17 @@ DIAFILE_DIRS = # generate a warning when it encounters a \startuml command in this case and # will not generate output for the diagram. -PLANTUML_JAR_PATH = +PLANTUML_JAR_PATH = # When using plantuml, the PLANTUML_CFG_FILE tag can be used to specify a # configuration file for plantuml. -PLANTUML_CFG_FILE = +PLANTUML_CFG_FILE = # When using plantuml, the specified paths are searched for files specified by # the !include statement in a plantuml block. -PLANTUML_INCLUDE_PATH = +PLANTUML_INCLUDE_PATH = # The DOT_GRAPH_MAX_NODES tag can be used to set the maximum number of nodes # that will be shown in the graph. If the number of nodes in a graph becomes diff --git a/Makefile b/Makefile index 4797c75..c368d50 100644 --- a/Makefile +++ b/Makefile @@ -17,13 +17,13 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ VERSION := "0.0.2" -CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g +CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG LDFLAGS := -lm $(TARGET): $(OBJS) Makefile $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) -doc: $(SRCS) Makefile +doc: $(SRCS) Makefile Doxyfile doxygen format: $(SRCS) $(HDRS) Makefile @@ -38,7 +38,7 @@ test: $(OBJS) $(TESTS) Makefile .PHONY: clean clean: - $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ *~ + $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~ repl: $(TARGET) -p 2> psse.log diff --git a/lisp/defun.lisp b/lisp/defun.lisp index e86df35..cec893b 100644 --- a/lisp/defun.lisp +++ b/lisp/defun.lisp @@ -1,10 +1,12 @@ -;; Because I don't (yet) have syntax for varargs, the body must be passed -;; to defun as a list of sexprs. +(set! list (lambda l l)) + +(set! symbolp (lambda (x) (equal (type x) "SYMB"))) + (set! defun! (nlambda form (cond ((symbolp (car form)) - (set (car form) (apply lambda (cdr form)))) + (set (car form) (apply 'lambda (cdr form)))) (t nil)))) (defun! square (x) (* x x)) diff --git a/src/arith/bignum.c b/src/arith/bignum.c new file mode 100644 index 0000000..a21a7df --- /dev/null +++ b/src/arith/bignum.c @@ -0,0 +1,14 @@ +/* + * bignum.c + * + * Allocation of and operations on arbitrary precision integers. + * + * (c) 2018 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +/* + * Bignums generally follow Knuth, vol 2, 4.3. The word size is 64 bits, + * and words are stored in individual cons-space objects, comprising the + * word itself and a pointer to the next word in the number. + */ diff --git a/src/arith/bignum.h b/src/arith/bignum.h new file mode 100644 index 0000000..05c9073 --- /dev/null +++ b/src/arith/bignum.h @@ -0,0 +1,16 @@ +/** + * bignum.h + * + * functions for bignum cells. + * + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __bignum_h +#define __bignum_h + + + +#endif diff --git a/src/integer.c b/src/arith/integer.c similarity index 90% rename from src/integer.c rename to src/arith/integer.c index 999c803..5239746 100644 --- a/src/integer.c +++ b/src/arith/integer.c @@ -13,7 +13,7 @@ #include "conspage.h" #include "consspaceobject.h" -#include "read.h" +#include "debug.h" /** * return the numeric value of this cell, as a C primitive double, not @@ -36,12 +36,12 @@ long double numeric_value( struct cons_pointer pointer ) { /** * Allocate an integer cell representing this value and return a cons pointer to it. */ -struct cons_pointer make_integer( long int value ) { +struct cons_pointer make_integer( int64_t value ) { struct cons_pointer result = allocate_cell( INTEGERTAG ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; - dump_object( stderr, result ); + debug_dump_object( result, DEBUG_ARITH ); return result; } diff --git a/src/integer.h b/src/arith/integer.h similarity index 88% rename from src/integer.h rename to src/arith/integer.h index d44f34d..00b94a6 100644 --- a/src/integer.h +++ b/src/arith/integer.h @@ -16,6 +16,6 @@ long double numeric_value( struct cons_pointer pointer ); /** * Allocate an integer cell representing this value and return a cons pointer to it. */ -struct cons_pointer make_integer( long int value ); +struct cons_pointer make_integer( int64_t value ); #endif diff --git a/src/arith/peano.c b/src/arith/peano.c new file mode 100644 index 0000000..9f5e0fb --- /dev/null +++ b/src/arith/peano.c @@ -0,0 +1,636 @@ +/* + * peano.c + * + * Basic peano arithmetic + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +#include +#include + +#include "consspaceobject.h" +#include "conspage.h" +#include "debug.h" +#include "equal.h" +#include "integer.h" +#include "intern.h" +#include "lispops.h" +#include "print.h" +#include "ratio.h" +#include "read.h" +#include "real.h" +#include "stack.h" + +long double to_long_double( struct cons_pointer arg ); +int64_t to_long_int( struct cons_pointer arg ); +struct cons_pointer add_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ); + + +bool zerop( struct cons_pointer arg ) { + bool result = false; + struct cons_space_object cell = pointer2cell( arg ); + + switch ( cell.tag.value ) { + case INTEGERTV: + result = cell.payload.integer.value == 0; + break; + case RATIOTV: + result = zerop( cell.payload.ratio.dividend ); + break; + case REALTV: + result = ( cell.payload.real.value == 0 ); + break; + } + + return result; +} + +/** + * TODO: cannot throw an exception out of here, which is a problem + * if a ratio may legally have zero as a divisor, or something which is + * not a number is passed in. + */ +long double to_long_double( struct cons_pointer arg ) { + long double result = 0; /* not a number, as a long double */ + struct cons_space_object cell = pointer2cell( arg ); + + switch ( cell.tag.value ) { + case INTEGERTV: + result = ( double ) cell.payload.integer.value; + break; + case RATIOTV: + { + struct cons_space_object dividend = + pointer2cell( cell.payload.ratio.dividend ); + struct cons_space_object divisor = + pointer2cell( cell.payload.ratio.divisor ); + + result = + ( long double ) dividend.payload.integer.value / + divisor.payload.integer.value; + } + break; + case REALTV: + result = cell.payload.real.value; + break; + default: + result = NAN; + break; + } + + debug_print( L"to_long_double( ", DEBUG_ARITH ); + debug_print_object( arg, DEBUG_ARITH ); + debug_printf( DEBUG_ARITH, L") => %lf\n", result ); + + return result; +} + + +/** + * TODO: cannot throw an exception out of here, which is a problem + * if a ratio may legally have zero as a divisor, or something which is + * not a number (or is a big number) is passed in. + */ +int64_t to_long_int( struct cons_pointer arg ) { + int64_t result = 0; + struct cons_space_object cell = pointer2cell( arg ); + switch ( cell.tag.value ) { + case INTEGERTV: + result = cell.payload.integer.value; + break; + case RATIOTV: + result = lroundl( to_long_double( arg ) ); + break; + case REALTV: + result = lroundl( cell.payload.real.value ); + break; + } + return result; +} + + +/** +* return a cons_pointer indicating a number which is the sum of +* the numbers indicated by `arg1` and `arg2`. +*/ +struct cons_pointer add_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer result; + struct cons_space_object cell1 = pointer2cell( arg1 ); + struct cons_space_object cell2 = pointer2cell( arg2 ); + + debug_print( L"add_2( arg1 = ", DEBUG_ARITH ); + debug_print_object( arg1, DEBUG_ARITH ); + debug_print( L"; arg2 = ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); + + if ( zerop( arg1 ) ) { + result = arg2; + } else if ( zerop( arg2 ) ) { + result = arg1; + } else { + + switch ( cell1.tag.value ) { + case EXCEPTIONTV: + result = arg1; + break; + case INTEGERTV: + switch ( cell2.tag.value ) { + case EXCEPTIONTV: + result = arg2; + break; + case INTEGERTV: + result = make_integer( cell1.payload.integer.value + + cell2.payload.integer.value ); + break; + case RATIOTV: + result = + add_integer_ratio( frame_pointer, arg1, arg2 ); + break; + case REALTV: + result = + make_real( to_long_double( arg1 ) + + to_long_double( arg2 ) ); + break; + default: + result = throw_exception( c_string_to_lisp_string + ( L"Cannot add: not a number" ), + frame_pointer ); + break; + } + break; + case RATIOTV: + switch ( cell2.tag.value ) { + case EXCEPTIONTV: + result = arg2; + break; + case INTEGERTV: + result = + add_integer_ratio( frame_pointer, arg2, arg1 ); + break; + case RATIOTV: + result = add_ratio_ratio( frame_pointer, arg1, arg2 ); + break; + case REALTV: + result = + make_real( to_long_double( arg1 ) + + to_long_double( arg2 ) ); + break; + default: + result = throw_exception( c_string_to_lisp_string + ( L"Cannot add: not a number" ), + frame_pointer ); + break; + } + break; + case REALTV: + result = + make_real( to_long_double( arg1 ) + + to_long_double( arg2 ) ); + break; + default: + result = exceptionp( arg2 ) ? arg2 : + throw_exception( c_string_to_lisp_string + ( L"Cannot add: not a number" ), + frame_pointer ); + } + } + + debug_print( L"}; => ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); + + return result; +} + +/** + * Add an indefinite number of numbers together + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ +struct cons_pointer lisp_add( struct stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + struct cons_pointer result = make_integer( 0 ); + struct cons_pointer tmp; + + for ( int i = 0; + i < args_in_frame && + !nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) { + tmp = result; + result = add_2( frame, frame_pointer, result, frame->arg[i] ); + if ( !eq( tmp, result ) ) { + dec_ref( tmp ); + } + } + + struct cons_pointer more = frame->more; + while ( consp( more ) && !exceptionp( result ) ) { + tmp = result; + result = add_2( frame, frame_pointer, result, c_car( more ) ); + if ( !eq( tmp, result ) ) { + dec_ref( tmp ); + } + + more = c_cdr( more ); + } + + return result; +} + + +/** +* return a cons_pointer indicating a number which is the product of +* the numbers indicated by `arg1` and `arg2`. +*/ +struct cons_pointer multiply_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer result; + struct cons_space_object cell1 = pointer2cell( arg1 ); + struct cons_space_object cell2 = pointer2cell( arg2 ); + + debug_print( L"multiply_2( arg1 = ", DEBUG_ARITH ); + debug_print_object( arg1, DEBUG_ARITH ); + debug_print( L"; arg2 = ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L")", DEBUG_ARITH ); + + if ( zerop( arg1 ) ) { + result = arg2; + } else if ( zerop( arg2 ) ) { + result = arg1; + } else { + switch ( cell1.tag.value ) { + case EXCEPTIONTV: + result = arg1; + break; + case INTEGERTV: + switch ( cell2.tag.value ) { + case EXCEPTIONTV: + result = arg2; + break; + case INTEGERTV: + result = make_integer( cell1.payload.integer.value * + cell2.payload.integer.value ); + break; + case RATIOTV: + result = + multiply_integer_ratio( frame_pointer, arg1, + arg2 ); + break; + case REALTV: + result = + make_real( to_long_double( arg1 ) * + to_long_double( arg2 ) ); + break; + default: + result = throw_exception( c_string_to_lisp_string + ( L"Cannot multiply: not a number" ), + frame_pointer ); + break; + } + break; + case RATIOTV: + switch ( cell2.tag.value ) { + case EXCEPTIONTV: + result = arg2; + break; + case INTEGERTV: + result = + multiply_integer_ratio( frame_pointer, arg2, + arg1 ); + break; + case RATIOTV: + result = + multiply_ratio_ratio( frame_pointer, arg1, arg2 ); + break; + case REALTV: + result = + make_real( to_long_double( arg1 ) * + to_long_double( arg2 ) ); + break; + default: + result = throw_exception( c_string_to_lisp_string + ( L"Cannot multiply: not a number" ), + frame_pointer ); + } + break; + case REALTV: + result = exceptionp( arg2 ) ? arg2 : + make_real( to_long_double( arg1 ) * + to_long_double( arg2 ) ); + break; + default: + result = throw_exception( c_string_to_lisp_string + ( L"Cannot multiply: not a number" ), + frame_pointer ); + break; + } + } + + debug_print( L" => ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); + + return result; +} + + +/** + * Multiply an indefinite number of numbers together + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ +struct cons_pointer lisp_multiply( struct + stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + struct cons_pointer result = make_integer( 1 ); + struct cons_pointer tmp; + + for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) + && !exceptionp( result ); i++ ) { + tmp = result; + result = multiply_2( frame, frame_pointer, result, frame->arg[i] ); + + if ( !eq( tmp, result ) ) { + dec_ref( tmp ); + } + } + + struct cons_pointer more = frame->more; + while ( consp( more ) + && !exceptionp( result ) ) { + tmp = result; + result = multiply_2( frame, frame_pointer, result, c_car( more ) ); + + if ( !eq( tmp, result ) ) { + dec_ref( tmp ); + } + + more = c_cdr( more ); + } + + return result; +} + +/** + * return a cons_pointer indicating a number which is the + * inverse of the number indicated by `arg`. + */ +struct cons_pointer inverse( struct cons_pointer frame, + struct cons_pointer arg ) { + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( arg ); + + switch ( cell.tag.value ) { + case EXCEPTIONTV: + result = arg; + break; + case INTEGERTV: + result = make_integer( 0 - to_long_int( arg ) ); + break; + case NILTV: + result = TRUE; + break; + case RATIOTV: + result = make_ratio( frame, + make_integer( 0 - + to_long_int( cell.payload. + ratio.dividend ) ), + cell.payload.ratio.divisor ); + break; + case REALTV: + result = make_real( 0 - to_long_double( arg ) ); + break; + case TRUETV: + result = NIL; + break; + } + + return result; +} + + +/** + * Subtract one number from another. + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ +struct cons_pointer lisp_subtract( struct + stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_space_object cell0 = pointer2cell( frame->arg[0] ); + struct cons_space_object cell1 = pointer2cell( frame->arg[1] ); + + switch ( cell0.tag.value ) { + case EXCEPTIONTV: + result = frame->arg[0]; + break; + case INTEGERTV: + switch ( cell1.tag.value ) { + case EXCEPTIONTV: + result = frame->arg[1]; + break; + case INTEGERTV: + result = make_integer( cell0.payload.integer.value + - cell1.payload.integer.value ); + break; + case RATIOTV:{ + struct cons_pointer tmp = + make_ratio( frame_pointer, frame->arg[0], + make_integer( 1 ) ); + inc_ref( tmp ); + result = + subtract_ratio_ratio( frame_pointer, tmp, + frame->arg[1] ); + dec_ref( tmp ); + } + break; + case REALTV: + result = + make_real( to_long_double( frame->arg[0] ) - + to_long_double( frame->arg[1] ) ); + break; + default: + result = throw_exception( c_string_to_lisp_string + ( L"Cannot subtract: not a number" ), + frame_pointer ); + break; + } + break; + case RATIOTV: + switch ( cell1.tag.value ) { + case EXCEPTIONTV: + result = frame->arg[1]; + break; + case INTEGERTV:{ + struct cons_pointer tmp = + make_ratio( frame_pointer, frame->arg[1], + make_integer( 1 ) ); + inc_ref( tmp ); + result = + subtract_ratio_ratio( frame_pointer, frame->arg[0], + tmp ); + dec_ref( tmp ); + } + break; + case RATIOTV: + result = + subtract_ratio_ratio( frame_pointer, frame->arg[0], + frame->arg[1] ); + break; + case REALTV: + result = + make_real( to_long_double( frame->arg[0] ) - + to_long_double( frame->arg[1] ) ); + break; + default: + result = throw_exception( c_string_to_lisp_string + ( L"Cannot subtract: not a number" ), + frame_pointer ); + break; + } + break; + case REALTV: + result = exceptionp( frame->arg[1] ) ? frame->arg[1] : + make_real( to_long_double( frame->arg[0] ) - + to_long_double( frame->arg[1] ) ); + break; + default: + result = throw_exception( c_string_to_lisp_string + ( L"Cannot subtract: not a number" ), + frame_pointer ); + break; + } + + // and if not nilp[frame->arg[2]) we also have an error. + + return result; +} + +/** + * Divide one number by another. + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer or real. + */ +struct cons_pointer lisp_divide( struct + stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); + struct cons_space_object arg1 = pointer2cell( frame->arg[1] ); + + switch ( arg0.tag.value ) { + case EXCEPTIONTV: + result = frame->arg[0]; + break; + case INTEGERTV: + switch ( arg1.tag.value ) { + case EXCEPTIONTV: + result = frame->arg[1]; + break; + case INTEGERTV:{ + struct cons_pointer unsimplified = + make_ratio( frame_pointer, frame->arg[0], + frame->arg[1] ); + /* OK, if result may be unsimplified, we should not inc_ref it + * - but if not, we should dec_ref it. */ + result = simplify_ratio( frame_pointer, unsimplified ); + if ( !eq( unsimplified, result ) ) { + dec_ref( unsimplified ); + } + } + break; + case RATIOTV:{ + struct cons_pointer one = make_integer( 1 ); + struct cons_pointer ratio = + make_ratio( frame_pointer, frame->arg[0], one ); + result = + divide_ratio_ratio( frame_pointer, ratio, + frame->arg[1] ); + dec_ref( ratio ); + } + break; + case REALTV: + result = + make_real( to_long_double( frame->arg[0] ) / + to_long_double( frame->arg[1] ) ); + break; + default: + result = throw_exception( c_string_to_lisp_string + ( L"Cannot divide: not a number" ), + frame_pointer ); + break; + } + break; + case RATIOTV: + switch ( arg1.tag.value ) { + case EXCEPTIONTV: + result = frame->arg[1]; + break; + case INTEGERTV:{ + struct cons_pointer one = make_integer( 1 ); + inc_ref( one ); + struct cons_pointer ratio = + make_ratio( frame_pointer, frame->arg[1], one ); + inc_ref( ratio ); + result = + divide_ratio_ratio( frame_pointer, frame->arg[0], + ratio ); + dec_ref( ratio ); + dec_ref( one ); + } + break; + case RATIOTV: + result = + divide_ratio_ratio( frame_pointer, frame->arg[0], + frame->arg[1] ); + break; + case REALTV: + result = + make_real( to_long_double( frame->arg[0] ) / + to_long_double( frame->arg[1] ) ); + break; + default: + result = throw_exception( c_string_to_lisp_string + ( L"Cannot divide: not a number" ), + frame_pointer ); + break; + } + break; + case REALTV: + result = exceptionp( frame->arg[1] ) ? frame->arg[1] : + make_real( to_long_double( frame->arg[0] ) / + to_long_double( frame->arg[1] ) ); + break; + default: + result = throw_exception( c_string_to_lisp_string + ( L"Cannot divide: not a number" ), + frame_pointer ); + break; + } + + return result; +} diff --git a/src/peano.h b/src/arith/peano.h similarity index 72% rename from src/peano.h rename to src/arith/peano.h index 79735c0..f1c21b4 100644 --- a/src/peano.h +++ b/src/arith/peano.h @@ -23,7 +23,8 @@ extern "C" { * @return a pointer to an integer or real. */ struct cons_pointer - lisp_add( struct stack_frame *frame, struct cons_pointer env ); + lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Multiply an indefinite number of numbers together @@ -32,7 +33,9 @@ extern "C" { * @return a pointer to an integer or real. */ struct cons_pointer - lisp_multiply( struct stack_frame *frame, struct cons_pointer env ); + lisp_multiply( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Subtract one number from another. @@ -41,7 +44,9 @@ extern "C" { * @return a pointer to an integer or real. */ struct cons_pointer - lisp_subtract( struct stack_frame *frame, struct cons_pointer env ); + lisp_subtract( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Divide one number by another. @@ -50,7 +55,8 @@ extern "C" { * @return a pointer to an integer or real. */ struct cons_pointer - lisp_divide( struct stack_frame *frame, struct cons_pointer env ); + lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); #ifdef __cplusplus } diff --git a/src/arith/ratio.c b/src/arith/ratio.c new file mode 100644 index 0000000..ca83335 --- /dev/null +++ b/src/arith/ratio.c @@ -0,0 +1,333 @@ +/* + * ratio.c + * + * functions for rational number cells. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#define _GNU_SOURCE +#include +#include + +#include "conspage.h" +#include "consspaceobject.h" +#include "debug.h" +#include "equal.h" +#include "integer.h" +#include "lispops.h" +#include "print.h" +#include "ratio.h" + + +/* + * declared in peano.c, can't include piano.h here because + * circularity. TODO: refactor. + */ +struct cons_pointer inverse( struct cons_pointer frame_pointer, + struct cons_pointer arg ); + +/** + * return, as a int64_t, the greatest common divisor of `m` and `n`, + */ +int64_t greatest_common_divisor( int64_t m, int64_t n ) { + int o; + while ( m ) { + o = m; + m = n % m; + n = o; + } + + return o; +} + +/** + * return, as a int64_t, the least common multiple of `m` and `n`, + */ +int64_t least_common_multiple( int64_t m, int64_t n ) { + return m / greatest_common_divisor( m, n ) * n; +} + +/** + * return a cons_pointer indicating a number which is of the + * same value as the ratio indicated by `arg`, but which may + * be in a simplified representation. If `arg` isn't a ratio, + * will throw exception. + */ +struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg ) { + struct cons_pointer result = arg; + + if ( ratiop( arg ) ) { + int64_t ddrv = + pointer2cell( pointer2cell( arg ).payload.ratio.dividend ). + payload.integer.value, drrv = + pointer2cell( pointer2cell( arg ).payload.ratio.divisor ). + payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv ); + + if ( gcd > 1 ) { + if ( drrv / gcd == 1 ) { + result = make_integer( ddrv / gcd ); + } else { + result = + make_ratio( frame_pointer, make_integer( ddrv / gcd ), + make_integer( drrv / gcd ) ); + } + } + } else { + result = + throw_exception( make_cons( c_string_to_lisp_string + ( L"Shouldn't happen: bad arg to simplify_ratio" ), + arg ), frame_pointer ); + } + + return result; +} + + + +/** + * return a cons_pointer indicating a number which is the sum of + * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, + * this is going to break horribly. + */ +struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer r, result; + + debug_print( L"add_ratio_ratio( arg1 = ", DEBUG_ARITH ); + debug_print_object( arg1, DEBUG_ARITH ); + debug_print( L"; arg2 = ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L")\n", DEBUG_ARITH ); + + if ( ratiop( arg1 ) && ratiop( arg2 ) ) { + struct cons_space_object cell1 = pointer2cell( arg1 ); + struct cons_space_object cell2 = pointer2cell( arg2 ); + int64_t dd1v = + pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, + dd2v = + pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, + dr1v = + pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, + dr2v = + pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, + lcm = least_common_multiple( dr1v, dr2v ), + m1 = lcm / dr1v, m2 = lcm / dr2v; + + debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); + + if ( dr1v == dr2v ) { + r = make_ratio( frame_pointer, + make_integer( dd1v + dd2v ), + cell1.payload.ratio.divisor ); + } else { + struct cons_pointer dd1vm = make_integer( dd1v * m1 ), + dr1vm = make_integer( dr1v * m1 ), + dd2vm = make_integer( dd2v * m2 ), + dr2vm = make_integer( dr2v * m2 ), + r1 = make_ratio( frame_pointer, dd1vm, dr1vm ), + r2 = make_ratio( frame_pointer, dd2vm, dr2vm ); + + r = add_ratio_ratio( frame_pointer, r1, r2 ); + + /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were + * never incremented except when making r1 and r2, decrementing + * r1 and r2 should be enought to garbage collect them. */ + dec_ref( r1 ); + dec_ref( r2 ); + } + + result = simplify_ratio( frame_pointer, r ); + if ( !eq( r, result ) ) { + dec_ref( r ); + } + } else { + result = + throw_exception( make_cons( c_string_to_lisp_string + ( L"Shouldn't happen: bad arg to add_ratio_ratio" ), + make_cons( arg1, + make_cons( arg2, NIL ) ) ), + frame_pointer ); + } + + debug_print( L" => ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); + + return result; +} + + +/** + * return a cons_pointer indicating a number which is the sum of + * the intger indicated by `intarg` and the ratio indicated by + * `ratarg`. If you pass other types, this is going to break horribly. + */ +struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, + struct cons_pointer intarg, + struct cons_pointer ratarg ) { + struct cons_pointer result; + + if ( integerp( intarg ) && ratiop( ratarg ) ) { + struct cons_pointer one = make_integer( 1 ), + ratio = make_ratio( frame_pointer, intarg, one ); + + result = add_ratio_ratio( frame_pointer, ratio, ratarg ); + + dec_ref( one ); + dec_ref( ratio ); + } else { + result = + throw_exception( make_cons( c_string_to_lisp_string + ( L"Shouldn't happen: bad arg to add_integer_ratio" ), + make_cons( intarg, + make_cons( ratarg, + NIL ) ) ), + frame_pointer ); + } + + return result; +} + +/** + * return a cons_pointer to a ratio which represents the value of the ratio + * indicated by `arg1` divided by the ratio indicated by `arg2`. If either + * of these aren't RTIO cells, something horrid will happen and it is YOUR FAULT. + */ +struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer i = make_ratio( frame_pointer, + pointer2cell( arg2 ).payload. + ratio.divisor, + pointer2cell( arg2 ).payload. + ratio.dividend ), + result = + multiply_ratio_ratio( frame_pointer, arg1, i ); + + dec_ref( i ); + + return result; +} + +/** + * return a cons_pointer indicating a number which is the product of + * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, + * this is going to break horribly. + */ +struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct + cons_pointer arg1, struct + cons_pointer arg2 ) { + struct cons_pointer result; + + debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH ); + debug_print_object( arg1, DEBUG_ARITH ); + debug_print( L"; arg2 = ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L")\n", DEBUG_ARITH ); + + if ( ratiop( arg1 ) && ratiop( arg2 ) ) { + struct cons_space_object cell1 = pointer2cell( arg1 ); + struct cons_space_object cell2 = pointer2cell( arg2 ); + int64_t dd1v = + pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value, + dd2v = + pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value, + dr1v = + pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value, + dr2v = + pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value, + ddrv = dd1v * dd2v, drrv = dr1v * dr2v; + + struct cons_pointer unsimplified = + make_ratio( frame_pointer, make_integer( ddrv ), + make_integer( drrv ) ); + result = simplify_ratio( frame_pointer, unsimplified ); + + if ( !eq( unsimplified, result ) ) { + dec_ref( unsimplified ); + } + } else { + result = + throw_exception( c_string_to_lisp_string + ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ), + frame_pointer ); + } + + return result; +} + +/** + * return a cons_pointer indicating a number which is the product of + * the intger indicated by `intarg` and the ratio indicated by + * `ratarg`. If you pass other types, this is going to break horribly. + */ +struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, + struct cons_pointer intarg, + struct cons_pointer ratarg ) { + struct cons_pointer result; + + if ( integerp( intarg ) && ratiop( ratarg ) ) { + struct cons_pointer one = make_integer( 1 ), + ratio = make_ratio( frame_pointer, intarg, one ); + result = multiply_ratio_ratio( frame_pointer, ratio, ratarg ); + + dec_ref( one ); + dec_ref( ratio ); + } else { + result = + throw_exception( c_string_to_lisp_string + ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ), + frame_pointer ); + } + + return result; +} + + +/** + * return a cons_pointer indicating a number which is the difference of + * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, + * this is going to break horribly. + */ +struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer i = inverse( frame_pointer, arg2 ), + result = add_ratio_ratio( frame_pointer, arg1, i ); + + dec_ref( i ); + + return result; +} + + +/** + * Construct a ratio frame from these two pointers, expected to be integers + * or (later) bignums, in the context of this stack_frame. + */ +struct cons_pointer make_ratio( struct cons_pointer frame_pointer, + struct cons_pointer dividend, + struct cons_pointer divisor ) { + struct cons_pointer result; + if ( integerp( dividend ) && integerp( divisor ) ) { + inc_ref( dividend ); + inc_ref( divisor ); + result = allocate_cell( RATIOTAG ); + struct cons_space_object *cell = &pointer2cell( result ); + cell->payload.ratio.dividend = dividend; + cell->payload.ratio.divisor = divisor; + } else { + result = + throw_exception( c_string_to_lisp_string + ( L"Dividend and divisor of a ratio must be integers" ), + frame_pointer ); + } + debug_dump_object( result, DEBUG_ARITH ); + + + return result; +} diff --git a/src/arith/ratio.h b/src/arith/ratio.h new file mode 100644 index 0000000..5a3b0d6 --- /dev/null +++ b/src/arith/ratio.h @@ -0,0 +1,46 @@ +/** + * ratio.h + * + * functions for rational number cells. + * + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __ratio_h +#define __ratio_h + +struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg ); + +struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ); + +struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, + struct cons_pointer intarg, + struct cons_pointer ratarg ); + +struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ); + +struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct + cons_pointer arg1, struct + cons_pointer arg2 ); + +struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, + struct cons_pointer intarg, + struct cons_pointer ratarg ); + +struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ); + +struct cons_pointer make_ratio( struct cons_pointer frame_pointer, + struct cons_pointer dividend, + struct cons_pointer divisor ); + + +#endif diff --git a/src/real.c b/src/arith/real.c similarity index 89% rename from src/real.c rename to src/arith/real.c index 526dca5..84ba899 100644 --- a/src/real.c +++ b/src/arith/real.c @@ -9,10 +9,11 @@ #include "conspage.h" #include "consspaceobject.h" +#include "debug.h" #include "read.h" /** - * Allocate a real number cell representing this value and return a cons + * Allocate a real number cell representing this value and return a cons * pointer to it. * @param value the value to wrap; * @return a real number cell wrapping this value. @@ -22,5 +23,7 @@ struct cons_pointer make_real( long double value ) { struct cons_space_object *cell = &pointer2cell( result ); cell->payload.real.value = value; + debug_dump_object( result, DEBUG_ARITH ); + return result; } diff --git a/src/real.h b/src/arith/real.h similarity index 100% rename from src/real.h rename to src/arith/real.h diff --git a/src/debug.c b/src/debug.c new file mode 100644 index 0000000..b21f4af --- /dev/null +++ b/src/debug.c @@ -0,0 +1,99 @@ +/** + * debug.c + * + * Better debug log messages. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#include "consspaceobject.h" +#include "debug.h" +#include "dump.h" +#include "print.h" + +/** + * the controlling flags for `debug_print`; set in `init.c`, q.v. + */ +int verbosity = 0; + +/** + * print this debug `message` to stderr, if `verbosity` matches `level`. + * `verbosity is a set of flags, see debug_print.h; so you can + * turn debugging on for only one part of the system. + */ +void debug_print( wchar_t *message, int level ) { +#ifdef DEBUG + if ( level & verbosity ) { + fwide( stderr, 1 ); + fputws( message, stderr ); + } +#endif +} + +/** + * print a line feed to stderr, if `verbosity` matches `level`. + * `verbosity is a set of flags, see debug_print.h; so you can + * turn debugging on for only one part of the system. + */ +void debug_println( int level ) { +#ifdef DEBUG + if ( level & verbosity ) { + fwide( stderr, 1 ); + fputws( L"\n", stderr ); + } +#endif +} + + +/** + * `wprintf` adapted for the debug logging system. Print to stderr only + * `verbosity` matches `level`. All other arguments as for `wprintf`. + */ +void debug_printf( int level, wchar_t * format, ...) { + #ifdef DEBUG + if ( level & verbosity ) { + fwide( stderr, 1 ); + va_list(args); + va_start(args, format); + vfwprintf(stderr, format, args); + } + #endif +} + +/** + * print the object indicated by this `pointer` to stderr, if `verbosity` + * matches `level`.`verbosity is a set of flags, see debug_print.h; so you can + * turn debugging on for only one part of the system. + */ +void debug_print_object( struct cons_pointer pointer, int level ) { +#ifdef DEBUG + if ( level & verbosity ) { + fwide( stderr, 1 ); + print( stderr, pointer ); + } +#endif +} + +/** + * Like `dump_object`, q.v., but protected by the verbosity mechanism. + */ +void debug_dump_object( struct cons_pointer pointer, int level ) { +#ifdef DEBUG + if ( level & verbosity ) { + fwide( stderr, 1 ); + dump_object( stderr, pointer ); + } +#endif +} diff --git a/src/debug.h b/src/debug.h new file mode 100644 index 0000000..22f5591 --- /dev/null +++ b/src/debug.h @@ -0,0 +1,33 @@ +/** + * debug.h + * + * Better debug log messages. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include + +#ifndef __debug_print_h +#define __debug_print_h + +#define DEBUG_ALLOC 1 +#define DEBUG_STACK 2 +#define DEBUG_ARITH 4 +#define DEBUG_EVAL 8 +#define DEBUG_LAMBDA 16 +#define DEBUG_BOOTSTRAP 32 +#define DEBUG_IO 64 +#define DEBUG_REPL 128 + +extern int verbosity; + +void debug_print( wchar_t *message, int level ); +void debug_println( int level ); +void debug_printf( int level, wchar_t * format, ...); +void debug_print_object( struct cons_pointer pointer, int level ); +void debug_dump_object( struct cons_pointer pointer, int level ); + +#endif diff --git a/src/init.c b/src/init.c index 876bdad..d81aa00 100644 --- a/src/init.c +++ b/src/init.c @@ -11,26 +11,32 @@ #include #include +#include #include #include #include "version.h" #include "conspage.h" #include "consspaceobject.h" +#include "debug.h" #include "intern.h" #include "lispops.h" #include "peano.h" #include "print.h" #include "repl.h" -void bind_function( char *name, struct cons_pointer ( *executable ) - ( struct stack_frame *, struct cons_pointer ) ) { +// extern char *optarg; /* defined in unistd.h */ + +void bind_function( wchar_t *name, struct cons_pointer ( *executable ) + ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ) ) { deep_bind( c_string_to_lisp_symbol( name ), make_function( NIL, executable ) ); } -void bind_special( char *name, struct cons_pointer ( *executable ) - ( struct stack_frame * frame, struct cons_pointer env ) ) { +void bind_special( wchar_t *name, struct cons_pointer ( *executable ) + ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ) ) { deep_bind( c_string_to_lisp_symbol( name ), make_special( NIL, executable ) ); } @@ -46,7 +52,7 @@ int main( int argc, char *argv[] ) { bool dump_at_end = false; bool show_prompt = false; - while ( ( option = getopt( argc, argv, "pdc" ) ) != -1 ) { + while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { switch ( option ) { case 'c': print_use_colours = true; @@ -57,6 +63,9 @@ int main( int argc, char *argv[] ) { case 'p': show_prompt = true; break; + case 'v': + verbosity = atoi( optarg ); + break; default: fwprintf( stderr, L"Unexpected option %c\n", option ); break; @@ -69,51 +78,60 @@ int main( int argc, char *argv[] ) { VERSION ); } + debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP ); + initialise_cons_pages( ); + debug_print( L"Initialised cons pages, about to bind\n", DEBUG_BOOTSTRAP ); + /* * privileged variables (keywords) */ - deep_bind( c_string_to_lisp_symbol( "nil" ), NIL ); - deep_bind( c_string_to_lisp_symbol( "t" ), TRUE ); + deep_bind( c_string_to_lisp_symbol( L"nil" ), NIL ); + deep_bind( c_string_to_lisp_symbol( L"t" ), TRUE ); /* * primitive function operations */ - bind_function( "add", &lisp_add ); - bind_function( "apply", &lisp_apply ); - bind_function( "assoc", &lisp_assoc ); - bind_function( "car", &lisp_car ); - bind_function( "cdr", &lisp_cdr ); - bind_function( "cons", &lisp_cons ); - bind_function( "divide", &lisp_divide ); - bind_function( "eq", &lisp_eq ); - bind_function( "equal", &lisp_equal ); - bind_function( "eval", &lisp_eval ); - bind_function( "multiply", &lisp_multiply ); - bind_function( "read", &lisp_read ); - bind_function( "oblist", &lisp_oblist ); - bind_function( "print", &lisp_print ); - bind_function( "progn", &lisp_progn ); - bind_function( "set", &lisp_set ); - bind_function( "subtract", &lisp_subtract ); - bind_function( "type", &lisp_type ); + bind_function( L"add", &lisp_add ); + bind_function( L"apply", &lisp_apply ); + bind_function( L"assoc", &lisp_assoc ); + bind_function( L"car", &lisp_car ); + bind_function( L"cdr", &lisp_cdr ); + bind_function( L"cons", &lisp_cons ); + bind_function( L"divide", &lisp_divide ); + bind_function( L"eq", &lisp_eq ); + bind_function( L"equal", &lisp_equal ); + bind_function( L"eval", &lisp_eval ); + bind_function( L"exception", &lisp_exception ); + bind_function( L"multiply", &lisp_multiply ); + bind_function( L"read", &lisp_read ); + bind_function( L"oblist", &lisp_oblist ); + bind_function( L"print", &lisp_print ); + bind_function( L"progn", &lisp_progn ); + bind_function( L"reverse", &lisp_reverse ); + bind_function( L"set", &lisp_set ); + bind_function( L"subtract", &lisp_subtract ); + bind_function( L"throw", &lisp_exception ); + bind_function( L"type", &lisp_type ); - bind_function( "+", &lisp_add ); - bind_function( "*", &lisp_multiply ); - bind_function( "-", &lisp_subtract ); - bind_function( "/", &lisp_divide ); - bind_function( "=", &lisp_equal ); + bind_function( L"+", &lisp_add ); + bind_function( L"*", &lisp_multiply ); + bind_function( L"-", &lisp_subtract ); + bind_function( L"/", &lisp_divide ); + bind_function( L"=", &lisp_equal ); /* * primitive special forms */ - bind_special( "cond", &lisp_cond ); - bind_special( "lambda", &lisp_lambda ); - bind_special( "nlambda", &lisp_nlambda ); - bind_special( "progn", &lisp_progn ); - bind_special( "quote", &lisp_quote ); - bind_special( "set!", &lisp_set_shriek ); + bind_special( L"cond", &lisp_cond ); + bind_special( L"lambda", &lisp_lambda ); + // bind_special( L"λ", &lisp_lambda ); + bind_special( L"nlambda", &lisp_nlambda ); + // bind_special( L"nλ", &lisp_nlambda ); + bind_special( L"progn", &lisp_progn ); + bind_special( L"quote", &lisp_quote ); + bind_special( L"set!", &lisp_set_shriek ); repl( stdin, stdout, stderr, show_prompt ); diff --git a/src/conspage.c b/src/memory/conspage.c similarity index 82% rename from src/conspage.c rename to src/memory/conspage.c index ad83680..cf87028 100644 --- a/src/conspage.c +++ b/src/memory/conspage.c @@ -18,6 +18,8 @@ #include "consspaceobject.h" #include "conspage.h" +#include "debug.h" +#include "dump.h" /** * Flag indicating whether conspage initialisation has been done. @@ -64,7 +66,7 @@ void make_cons_page( ) { cell->count = MAXREFERENCE; cell->payload.free.car = NIL; cell->payload.free.cdr = NIL; - fwprintf( stderr, L"Allocated special cell NIL\n" ); + debug_printf( DEBUG_ALLOC, L"Allocated special cell NIL\n" ); break; case 1: /* @@ -78,7 +80,7 @@ void make_cons_page( ) { cell->payload.free.cdr = ( struct cons_pointer ) { 0, 1 }; - fwprintf( stderr, L"Allocated special cell T\n" ); + debug_printf( DEBUG_ALLOC, L"Allocated special cell T\n" ); break; } } else { @@ -95,7 +97,7 @@ void make_cons_page( ) { initialised_cons_pages++; } else { - fwprintf( stderr, + debug_printf( DEBUG_ALLOC, L"FATAL: Failed to allocate memory for cons page %d\n", initialised_cons_pages ); exit( 1 ); @@ -127,6 +129,9 @@ void dump_pages( FILE * output ) { void free_cell( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); + debug_printf( DEBUG_ALLOC, L"Freeing cell " ); + debug_dump_object( pointer, DEBUG_ALLOC ); + switch ( cell->tag.value ) { /* for all the types of cons-space object which point to other * cons-space objects, cascade the decrement. */ @@ -145,6 +150,10 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.lambda.args ); dec_ref( cell->payload.lambda.body ); break; + case RATIOTV: + dec_ref( cell->payload.ratio.dividend ); + dec_ref( cell->payload.ratio.divisor ); + break; case SPECIALTV: dec_ref( cell->payload.special.source ); break; @@ -152,24 +161,30 @@ void free_cell( struct cons_pointer pointer ) { case SYMBOLTV: dec_ref( cell->payload.string.cdr ); break; + case VECTORPOINTTV: + /* for vector space pointers, free the actual vector-space + * object. Dangerous! */ + debug_printf( DEBUG_ALLOC, L"About to free vector-space object at %ld\n", + cell->payload.vectorp.address ); + //free( ( void * ) cell->payload.vectorp.address ); + break; + } if ( !check_tag( pointer, FREETAG ) ) { if ( cell->count == 0 ) { - fwprintf( stderr, L"Freeing cell " ); - dump_object( stderr, pointer ); - strncpy( &cell->tag.bytes[0], FREETAG, 4 ); + strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); cell->payload.free.car = NIL; cell->payload.free.cdr = freelist; freelist = pointer; } else { - fwprintf( stderr, - L"Attempt to free cell with %d dangling references at page %d, offset %d\n", + debug_printf( DEBUG_ALLOC, + L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n", cell->count, pointer.page, pointer.offset ); } } else { - fwprintf( stderr, - L"Attempt to free cell which is already FREE at page %d, offset %d\n", + debug_printf( DEBUG_ALLOC, + L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n", pointer.page, pointer.offset ); } } @@ -194,19 +209,17 @@ struct cons_pointer allocate_cell( char *tag ) { if ( strncmp( &cell->tag.bytes[0], FREETAG, TAGLENGTH ) == 0 ) { freelist = cell->payload.free.cdr; - strncpy( &cell->tag.bytes[0], tag, 4 ); + strncpy( &cell->tag.bytes[0], tag, TAGLENGTH ); cell->count = 0; cell->payload.cons.car = NIL; cell->payload.cons.cdr = NIL; -#ifdef DEBUG - fwprintf( stderr, + debug_printf( DEBUG_ALLOC, L"Allocated cell of type '%s' at %d, %d \n", tag, result.page, result.offset ); -#endif } else { - fwprintf( stderr, L"WARNING: Allocating non-free cell!" ); + debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" ); } } @@ -225,7 +238,7 @@ void initialise_cons_pages( ) { make_cons_page( ); conspageinitihasbeencalled = true; } else { - fwprintf( stderr, + debug_printf( DEBUG_ALLOC, L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); } } diff --git a/src/conspage.h b/src/memory/conspage.h similarity index 98% rename from src/conspage.h rename to src/memory/conspage.h index 7b8b930..bc1361e 100644 --- a/src/conspage.h +++ b/src/memory/conspage.h @@ -19,7 +19,7 @@ * 4294967296. * * Note that this means the total number of addressable cons cells is - * 1.8e19, each of 20 bytes; or 3e20 bytes in total; and there are + * 1.8e19, each of 20 bytes; or 3e20 bytes in total; and there are * up to a maximum of 4e9 of heap space objects, each of potentially * 4e9 bytes. So we're talking about a potential total of 8e100 bytes * of addressable memory, which is only slightly more than the @@ -38,7 +38,7 @@ struct cons_page { }; /** - * The (global) pointer to the (global) freelist. Not sure whether this ultimately + * The (global) pointer to the (global) freelist. Not sure whether this ultimately * belongs in this file. */ extern struct cons_pointer freelist; diff --git a/src/consspaceobject.c b/src/memory/consspaceobject.c similarity index 60% rename from src/consspaceobject.c rename to src/memory/consspaceobject.c index 0fe28e3..f5cc8b8 100644 --- a/src/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -20,6 +20,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "debug.h" #include "print.h" #include "stack.h" @@ -54,7 +55,7 @@ void inc_ref( struct cons_pointer pointer ) { void dec_ref( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); - if ( cell->count <= MAXREFERENCE ) { + if ( cell->count > 0 ) { cell->count--; if ( cell->count == 0 ) { @@ -63,90 +64,6 @@ void dec_ref( struct cons_pointer pointer ) { } } -void dump_string_cell( FILE * output, wchar_t *prefix, - struct cons_pointer pointer ) { - struct cons_space_object cell = pointer2cell( pointer ); - if ( cell.payload.string.character == 0 ) { - fwprintf( output, - L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", - prefix, - cell.payload.string.cdr.page, cell.payload.string.cdr.offset, - cell.count ); - } else { - fwprintf( output, - L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n", - prefix, - ( wint_t ) cell.payload.string.character, - cell.payload.string.character, - cell.payload.string.cdr.page, - cell.payload.string.cdr.offset, cell.count ); - fwprintf( output, L"\t\t value: " ); - print( output, pointer ); - fwprintf( output, L"\n" ); - } -} - -/** - * dump the object at this cons_pointer to this output stream. - */ -void dump_object( FILE * output, struct cons_pointer pointer ) { - struct cons_space_object cell = pointer2cell( pointer ); - fwprintf( output, - L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n", - cell.tag.bytes[0], - cell.tag.bytes[1], - cell.tag.bytes[2], - cell.tag.bytes[3], - cell.tag.value, pointer.page, pointer.offset, cell.count ); - - switch ( cell.tag.value ) { - case CONSTV: - fwprintf( output, - L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n", - cell.payload.cons.car.page, - cell.payload.cons.car.offset, - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset, cell.count ); - break; - case EXCEPTIONTV: - fwprintf( output, L"\t\tException cell: " ); - print( output, cell.payload.exception.message ); - fwprintf( output, L"\n" ); - for ( struct stack_frame * frame = cell.payload.exception.frame; - frame != NULL; frame = frame->previous ) { - dump_frame( output, frame ); - } - break; - case FREETV: - fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset ); - break; - case INTEGERTV: - fwprintf( output, - L"\t\tInteger cell: value %ld, count %u\n", - cell.payload.integer.value, cell.count ); - break; - case LAMBDATV: - fwprintf( output, L"\t\tLambda cell; args: " ); - print( output, cell.payload.lambda.args ); - fwprintf( output, L";\n\t\t\tbody: " ); - print( output, cell.payload.lambda.body ); - break; - case READTV: - fwprintf( output, L"\t\tInput stream\n" ); - case REALTV: - fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", - cell.payload.real.value, cell.count ); - break; - case STRINGTV: - dump_string_cell( output, L"String", pointer ); - break; - case SYMBOLTV: - dump_string_cell( output, L"Symbol", pointer ); - break; - } -} /** * Construct a cons cell from this pair of pointers. @@ -170,20 +87,24 @@ struct cons_pointer make_cons( struct cons_pointer car, /** * Construct an exception cell. * @param message should be a lisp string describing the problem, but actually any cons pointer will do; - * @param frame should be the frame in which the exception occurred. + * @param frame_pointer should be the pointer to the frame in which the exception occurred. */ struct cons_pointer make_exception( struct cons_pointer message, - struct stack_frame *frame ) { + struct cons_pointer frame_pointer ) { + struct cons_pointer result = NIL; struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ inc_ref( message ); + inc_ref( frame_pointer ); cell->payload.exception.message = message; - cell->payload.exception.frame = frame; + cell->payload.exception.frame = frame_pointer; - return pointer; + result = pointer; + + return result; } @@ -192,7 +113,8 @@ struct cons_pointer make_exception( struct cons_pointer message, */ struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer ( *executable ) - ( struct stack_frame *, struct cons_pointer ) ) { + ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ) ) { struct cons_pointer pointer = allocate_cell( FUNCTIONTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -257,11 +179,13 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { cell->payload.string.character = c; cell->payload.string.cdr.page = tail.page; /* TODO: There's a problem here. Sometimes the offsets on - * strings are quite massively off. */ + * strings are quite massively off. Fix is probably + * cell->payload.string.cdr = tsil */ cell->payload.string.cdr.offset = tail.offset; } else { - fwprintf( stderr, - L"Warning: only NIL and %s can be appended to %s\n", + // TODO: should throw an exception! + debug_printf( DEBUG_ALLOC, + L"Warning: only NIL and %s can be prepended to %s\n", tag, tag ); } @@ -290,7 +214,8 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) - ( struct stack_frame * frame, struct cons_pointer env ) ) { + ( struct stack_frame * frame, + struct cons_pointer, struct cons_pointer env ) ) { struct cons_pointer pointer = allocate_cell( SPECIALTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -327,26 +252,26 @@ struct cons_pointer make_write_stream( FILE * output ) { } /** - * Return a lisp string representation of this old skool ASCII string. + * Return a lisp string representation of this wide character string. */ -struct cons_pointer c_string_to_lisp_string( char *string ) { +struct cons_pointer c_string_to_lisp_string( wchar_t *string ) { struct cons_pointer result = NIL; - for ( int i = strlen( string ); i > 0; i-- ) { - result = make_string( ( wint_t ) string[i - 1], result ); + for ( int i = wcslen( string ); i > 0; i-- ) { + result = make_string( string[i - 1], result ); } return result; } /** - * Return a lisp symbol representation of this old skool ASCII string. + * Return a lisp symbol representation of this wide character string. */ -struct cons_pointer c_string_to_lisp_symbol( char *symbol ) { +struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ) { struct cons_pointer result = NIL; - for ( int i = strlen( symbol ); i > 0; i-- ) { - result = make_symbol( ( wint_t ) symbol[i - 1], result ); + for ( int i = wcslen( symbol ); i > 0; i-- ) { + result = make_symbol( symbol[i - 1], result ); } return result; diff --git a/src/consspaceobject.h b/src/memory/consspaceobject.h similarity index 85% rename from src/consspaceobject.h rename to src/memory/consspaceobject.h index ed5cbd1..523fdaa 100644 --- a/src/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -28,6 +28,13 @@ /** * tag values, all of which must be 4 bytes. Must not collide with vector space tag values */ + +/** + * A word within a bignum - arbitrary precision integer. + */ +#define BIGNUMTAG "BIGN" +#define BIGNUMTV 1313294658 + /** * An ordinary cons cell: 1397641027 */ @@ -38,7 +45,6 @@ * An exception. */ #define EXCEPTIONTAG "EXEP" -/* TODO: this is wrong */ #define EXCEPTIONTV 1346721861 /** @@ -91,6 +97,12 @@ #define REALTAG "REAL" #define REALTV 1279346002 +/** + * A ratio. + */ +#define RATIOTAG "RTIO" +#define RATIOTV 1330205778 + /** * A special form - one whose arguments are not pre-evaluated but passed as a * s-expression. 1296453715 @@ -121,12 +133,11 @@ * A pointer to an object in vector space. */ #define VECTORPOINTTAG "VECP" - +#define VECTORPOINTTV 1346585942 /** * An open write stream. */ #define WRITETAG "WRIT" -/* TODO: this is wrong */ #define WRITETV 1414091351 /** @@ -157,6 +168,11 @@ */ #define nilp(conspoint) (check_tag(conspoint,NILTAG)) +/** + * true if conspointer points to a cons cell, else false + */ +#define bignump(conspoint) (check_tag(conspoint,BIGNUMTAG)) + /** * true if conspointer points to a cons cell, else false */ @@ -197,6 +213,11 @@ */ #define integerp(conspoint) (check_tag(conspoint,INTEGERTAG)) +/** + * true if conspointer points to a rational number cell, else false + */ +#define ratiop(conspoint) (check_tag(conspoint,RATIOTAG)) + /** * true if conspointer points to a read stream cell, else false */ @@ -211,7 +232,14 @@ * true if conspointer points to some sort of a number cell, * else false */ -#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,REALTAG)) +#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG)) + +#define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG)) + +/** + * true if thr conspointer points to a vector pointer. + */ +#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTAG)) /** * true if conspointer points to a write stream cell, else false. @@ -235,9 +263,10 @@ * An indirect pointer to a cons cell */ struct cons_pointer { - uint32_t page; /* the index of the page on which this cell - * resides */ - uint32_t offset; /* the index of the cell within the page */ + /** the index of the page on which this cell resides */ + uint32_t page; + /** the index of the cell within the page */ + uint32_t offset; }; /* @@ -250,15 +279,26 @@ struct cons_pointer { * here to avoid circularity. TODO: refactor. */ struct stack_frame { - struct stack_frame *previous; /* the previous frame */ + struct cons_pointer previous; /* the previous frame */ struct cons_pointer arg[args_in_frame]; /* * first 8 arument bindings */ struct cons_pointer more; /* list of any further argument bindings */ struct cons_pointer function; /* the function to be called */ + int args; }; +/** + * payload of a bignum cell. Intentionally similar to an integer payload, but + * with a next pointer. + */ +struct bignum_payload { + int64_t value; + struct cons_pointer next; +}; + + /** * payload of a cons cell. */ @@ -273,7 +313,7 @@ struct cons_payload { */ struct exception_payload { struct cons_pointer message; - struct stack_frame *frame; + struct cons_pointer frame; }; /** @@ -288,6 +328,7 @@ struct exception_payload { struct function_payload { struct cons_pointer source; struct cons_pointer ( *executable ) ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ); }; @@ -306,7 +347,7 @@ struct free_payload { * optional bignum object. */ struct integer_payload { - long int value; + int64_t value; }; /** @@ -317,10 +358,19 @@ struct lambda_payload { struct cons_pointer body; }; +/** + * payload for ratio cells. Both dividend and divisor must point to integer (or, later, bignum) cells. + */ +struct ratio_payload { + struct cons_pointer dividend; + struct cons_pointer divisor; +}; + /** * payload for a real number cell. Internals of this liable to change to give 128 bits * precision, but I'm not sure of the detail. - */ struct real_payload { + */ +struct real_payload { long double value; }; @@ -332,13 +382,11 @@ struct lambda_payload { * its argument list) and a cons pointer (representing its environment) and a * stack frame (representing the previous stack frame) as arguments and returns * a cons pointer (representing its result). - * - * NOTE that this means that special forms do not appear on the lisp stack, - * which may be confusing. TODO: think about this. */ struct special_payload { struct cons_pointer source; struct cons_pointer ( *executable ) ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ); }; @@ -361,6 +409,9 @@ struct string_payload { struct cons_pointer cdr; }; +/** + * payload of a vector pointer cell. + */ struct vectorp_payload { union { char bytes[TAGLENGTH]; /* the tag (type) of the @@ -371,9 +422,10 @@ struct vectorp_payload { * tag. */ uint32_t value; /* the tag considered as a number */ } tag; - uint64_t address; /* the address of the actual vector space - * object (TODO: will change when I actually - * implement vector space) */ + void *address; + /* the address of the actual vector space + * object (TODO: will change when I actually + * implement vector space) */ }; /** @@ -418,6 +470,10 @@ struct cons_space_object { * if tag == NILTAG; we'll treat the special cell NIL as just a cons */ struct cons_payload nil; + /* + * if tag == RATIOTAG + */ + struct ratio_payload ratio; /* * if tag == READTAG || tag == WRITETAG */ @@ -460,20 +516,11 @@ void inc_ref( struct cons_pointer pointer ); */ void dec_ref( struct cons_pointer pointer ); -/** - * dump the object at this cons_pointer to this output stream. - */ -void dump_object( FILE * output, struct cons_pointer pointer ); - struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr ); -/** - * Construct an exception cell. - * @param message should be a lisp string describing the problem, but actually any cons pointer will do; - * @param frame should be the frame in which the exception occurred. - */ + struct cons_pointer make_exception( struct cons_pointer message, - struct stack_frame *frame ); + struct cons_pointer frame_pointer ); /** * Construct a cell which points to an executable Lisp special form. @@ -481,6 +528,7 @@ struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer ( *executable ) ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ) ); /** @@ -496,12 +544,13 @@ struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer make_nlambda( struct cons_pointer args, struct cons_pointer body ); - /** +/** * Construct a cell which points to an executable Lisp special form. */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) ( struct stack_frame *, + struct cons_pointer, struct cons_pointer ) ); /** @@ -533,11 +582,11 @@ struct cons_pointer make_write_stream( FILE * output ); /** * Return a lisp string representation of this old skool ASCII string. */ -struct cons_pointer c_string_to_lisp_string( char *string ); +struct cons_pointer c_string_to_lisp_string( wchar_t *string ); /** * Return a lisp symbol representation of this old skool ASCII string. */ -struct cons_pointer c_string_to_lisp_symbol( char *symbol ); +struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ); #endif diff --git a/src/memory/cursor.c b/src/memory/cursor.c new file mode 100644 index 0000000..31a38b2 --- /dev/null +++ b/src/memory/cursor.c @@ -0,0 +1,9 @@ +/* + * a cursor is a cons-space object which holds: + * 1. a pointer to a vector (i.e. a vector-space object which holds an + * array of `cons_pointer`); + * 2. an integer offset into that array. + * + * this provides a mechanism for iterating through vectors (actually, in + * either direction) + */ diff --git a/src/memory/cursor.h b/src/memory/cursor.h new file mode 100644 index 0000000..a50aff6 Binary files /dev/null and b/src/memory/cursor.h differ diff --git a/src/memory/dump.c b/src/memory/dump.c new file mode 100644 index 0000000..e88332a --- /dev/null +++ b/src/memory/dump.c @@ -0,0 +1,140 @@ +/* + * dump.c + * + * Dump representations of both cons space and vector space objects. + * + * + * (c) 2018 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#include "conspage.h" +#include "consspaceobject.h" +#include "debug.h" +#include "print.h" +#include "stack.h" +#include "vectorspace.h" + + +void dump_string_cell( FILE * output, wchar_t *prefix, + struct cons_pointer pointer ) { + struct cons_space_object cell = pointer2cell( pointer ); + if ( cell.payload.string.character == 0 ) { + fwprintf( output, + L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", + prefix, + cell.payload.string.cdr.page, cell.payload.string.cdr.offset, + cell.count ); + } else { + fwprintf( output, + L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n", + prefix, + ( wint_t ) cell.payload.string.character, + cell.payload.string.character, + cell.payload.string.cdr.page, + cell.payload.string.cdr.offset, cell.count ); + fwprintf( output, L"\t\t value: " ); + print( output, pointer ); + fwprintf( output, L"\n" ); + } +} + +/** + * dump the object at this cons_pointer to this output stream. + */ +void dump_object( FILE * output, struct cons_pointer pointer ) { + struct cons_space_object cell = pointer2cell( pointer ); + fwprintf( output, + L"\t%4.4s (%d) at page %d, offset %d count %u\n", + cell.tag.bytes, + cell.tag.value, pointer.page, pointer.offset, cell.count ); + + switch ( cell.tag.value ) { + case CONSTV: + fwprintf( output, + L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u :", + cell.payload.cons.car.page, + cell.payload.cons.car.offset, + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset, cell.count ); + print( output, pointer); + fputws( L"\n", output); + break; + case EXCEPTIONTV: + fwprintf( output, L"\t\tException cell: " ); + dump_stack_trace( output, pointer ); + break; + case FREETV: + fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset ); + break; + case INTEGERTV: + fwprintf( output, + L"\t\tInteger cell: value %ld, count %u\n", + cell.payload.integer.value, cell.count ); + break; + case LAMBDATV: + fwprintf( output, L"\t\tLambda cell; args: " ); + print( output, cell.payload.lambda.args ); + fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell.payload.lambda.body ); + break; + case NILTV: + break; + case RATIOTV: + fwprintf( output, + L"\t\tRational cell: value %ld/%ld, count %u\n", + pointer2cell( cell.payload.ratio.dividend ). + payload.integer.value, + pointer2cell( cell.payload.ratio.divisor ). + payload.integer.value, cell.count ); + break; + case READTV: + fwprintf( output, L"\t\tInput stream\n" ); + break; + case REALTV: + fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", + cell.payload.real.value, cell.count ); + break; + case STRINGTV: + dump_string_cell( output, L"String", pointer ); + break; + case SYMBOLTV: + dump_string_cell( output, L"Symbol", pointer ); + break; + case TRUETV: + break; + case VECTORPOINTTV:{ + fwprintf( output, + L"\t\tPointer to vector-space object at %p\n", + cell.payload.vectorp.address ); + struct vector_space_object *vso = cell.payload.vectorp.address; + fwprintf( output, + L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n", + &vso->header.tag.bytes, vso->header.tag.value, vso->header.size ); + if (stackframep(vso)) { + dump_frame(output, pointer); + } + switch ( vso->header.tag.value ) { + case STACKFRAMETV: + dump_frame( output, pointer ); + break; + } + } + break; + case WRITETV: + fwprintf( output, L"\t\tOutput stream\n" ); + break; + } +} diff --git a/src/memory/dump.h b/src/memory/dump.h new file mode 100644 index 0000000..e49f453 --- /dev/null +++ b/src/memory/dump.h @@ -0,0 +1,29 @@ +/** + * dump.h + * + * Dump representations of both cons space and vector space objects. + * + * (c) 2018 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#ifndef __dump_h +#define __dump_h + + +/** + * dump the object at this cons_pointer to this output stream. + */ +void dump_object( FILE * output, struct cons_pointer pointer ); + + +#endif diff --git a/src/memory/stack.c b/src/memory/stack.c new file mode 100644 index 0000000..f91d896 --- /dev/null +++ b/src/memory/stack.c @@ -0,0 +1,298 @@ +/* + * stack.c + * + * The Lisp evaluation stack. + * + * Stack frames could be implemented in cons space; indeed, the stack + * could simply be an assoc list consed onto the front of the environment. + * But such a stack would be costly to search. The design sketched here, + * with stack frames as special objects, SHOULD be substantially more + * efficient, but does imply we need to generalise the idea of cons pages + * with freelists to a more general 'equal sized object pages', so that + * allocating/freeing stack frames can be more efficient. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "consspaceobject.h" +#include "conspage.h" +#include "debug.h" +#include "dump.h" +#include "lispops.h" +#include "print.h" +#include "stack.h" +#include "vectorspace.h" + +void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value) { + debug_printf(DEBUG_STACK, L"Setting register %d to ", reg); + debug_print_object(value, DEBUG_STACK); + debug_println(DEBUG_STACK); + frame->arg[reg++] = value; + inc_ref(value); + if (reg > frame->args) { + frame->args = reg; + } +} + + +/** + * get the actual stackframe object from this `pointer`, or NULL if + * `pointer` is not a stackframe pointer. + */ +struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { + struct stack_frame *result = NULL; + struct vector_space_object *vso = + pointer2cell( pointer ).payload.vectorp.address; + + if ( vectorpointp( pointer ) && stackframep( vso ) ) { + result = ( struct stack_frame * ) &( vso->payload ); + debug_printf( DEBUG_STACK, L"get_stack_frame: all good, returning %p\n", + result ); + } else { + debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_STACK ); + } + + return result; +} + +/** + * Make an empty stack frame, and return it. + * @param previous the current top-of-stack; + * @param env the environment in which evaluation happens. + * @return the new frame, or NULL if memory is exhausted. + */ +struct cons_pointer make_empty_frame( struct cons_pointer previous ) { + debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC ); + struct cons_pointer result = + make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) ); + + debug_dump_object( result, DEBUG_ALLOC ); + +// debug_printf( DEBUG_STACK, +// L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n", +// pointer_to_vso( result )->header.size, +// &pointer_to_vso( result )->header.tag.bytes ); + + if ( !nilp( result ) ) { + struct stack_frame *frame = get_stack_frame( result ); + /* + * TODO: later, pop a frame off a free-list of stack frames + */ + + frame->previous = previous; + + /* + * clearing the frame with memset would probably be slightly quicker, but + * this is clear. + */ + frame->more = NIL; + frame->function = NIL; + frame->args = 0; + + for ( int i = 0; i < args_in_frame; i++ ) { + frame->arg[i] = NIL; + } + } + debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC ); + debug_dump_object( result, DEBUG_ALLOC); + + return result; +} + +/** + * Allocate a new stack frame with its previous pointer set to this value, + * its arguments set up from these args, evaluated in this env. + * @param previous the current top-of-stack; + * @args the arguments to load into this frame; + * @param env the environment in which evaluation happens. + * @return the new frame, or an exception if one occurred while building it. + */ +struct cons_pointer make_stack_frame( struct cons_pointer previous, + struct cons_pointer args, + struct cons_pointer env ) { + debug_print( L"Entering make_stack_frame\n", DEBUG_STACK ); + struct cons_pointer result = make_empty_frame( previous ); + + if ( nilp( result ) ) { + /* i.e. out of memory */ + result = + make_exception( c_string_to_lisp_string( L"Memory exhausted." ), + previous ); + } else { + struct stack_frame *frame = get_stack_frame( result ); + + while ( frame->args < args_in_frame && consp( args )) { + /* iterate down the arg list filling in the arg slots in the + * frame. When there are no more slots, if there are still args, + * stash them on more */ + struct cons_space_object cell = pointer2cell( args ); + + /* + * TODO: if we were running on real massively parallel hardware, + * each arg except the first should be handed off to another + * processor to be evaled in parallel; but see notes here: + * https://github.com/simon-brooke/post-scarcity/wiki/parallelism + */ + struct cons_pointer val = eval_form(frame, result, cell.payload.cons.car, env); + if ( exceptionp( val ) ) { + result = val; + break; + } else { + debug_printf( DEBUG_STACK, L"Setting argument %d to ", frame->args); + debug_print_object(cell.payload.cons.car, DEBUG_STACK); + set_reg( frame, frame->args, val ); + } + + args = cell.payload.cons.cdr; + } + + if ( !exceptionp( result ) ) { + if ( consp( args ) ) { + /* if we still have args, eval them and stick the values on `more` */ + struct cons_pointer more = + eval_forms( get_stack_frame( previous ), previous, args, + env ); + frame->more = more; + inc_ref( more ); + } + + } + } + debug_print( L"make_stack_frame: returning\n", DEBUG_STACK ); + debug_dump_object( result, DEBUG_STACK ); + + return result; +} + +/** + * A 'special' frame is exactly like a normal stack frame except that the + * arguments are unevaluated. + * @param previous the previous stack frame; + * @param args a list of the arguments to be stored in this stack frame; + * @param env the execution environment; + * @return a new special frame. + */ +struct cons_pointer make_special_frame( struct cons_pointer previous, + struct cons_pointer args, + struct cons_pointer env ) { + debug_print( L"Entering make_special_frame\n", DEBUG_STACK ); + + struct cons_pointer result = make_empty_frame( previous ); + + if ( nilp( result ) ) { + /* i.e. out of memory */ + result = + make_exception( c_string_to_lisp_string( L"Memory exhausted." ), + previous ); + } else { + struct stack_frame *frame = get_stack_frame( result ); + + while ( frame->args < args_in_frame && !nilp( args )) { + /* iterate down the arg list filling in the arg slots in the + * frame. When there are no more slots, if there are still args, + * stash them on more */ + struct cons_space_object cell = pointer2cell( args ); + + set_reg( frame, frame->args, cell.payload.cons.car ); + + args = cell.payload.cons.cdr; + } + if ( !exceptionp( result ) ) { + if ( consp( args ) ) { + frame->more = args; + inc_ref( args ); + } + } + } + debug_print( L"make_special_frame: returning\n", DEBUG_STACK ); + debug_dump_object( result, DEBUG_STACK ); + + return result; +} + +/** + * Free this stack frame. + */ +void free_stack_frame( struct stack_frame *frame ) { + /* + * TODO: later, push it back on the stack-frame freelist + */ + for ( int i = 0; i < args_in_frame; i++ ) { + dec_ref( frame->arg[i] ); + } + if ( !nilp( frame->more ) ) { + dec_ref( frame->more ); + } + + free( frame ); +} + + +/** + * Dump a stackframe to this stream for debugging + * @param output the stream + * @param frame_pointer the pointer to the frame + */ +void dump_frame( FILE * output, struct cons_pointer frame_pointer ) { + struct stack_frame *frame = get_stack_frame( frame_pointer ); + + if ( frame != NULL ) { + fwprintf( output, L"Stack frame with %d arguments:\n", frame->args); + for ( int arg = 0; arg < frame->args; arg++ ) { + struct cons_space_object cell = pointer2cell( frame->arg[arg] ); + + fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg, + cell.tag.bytes[0], + cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3], + cell.count ); + + print( output, frame->arg[arg] ); + fputws( L"\n", output ); + } + if (!nilp(frame->more)) + { + fputws( L"More: \t", output ); + print( output, frame->more ); + fputws( L"\n", output ); + } + } +} + +void dump_stack_trace( FILE * output, struct cons_pointer pointer ) { + if ( exceptionp( pointer ) ) { + print( output, pointer2cell( pointer ).payload.exception.message ); + fputws( L"\n", output ); + dump_stack_trace( output, + pointer2cell( pointer ).payload.exception.frame ); + } else { + while ( vectorpointp( pointer ) + && stackframep( pointer_to_vso( pointer ) ) ) { + dump_frame( output, pointer ); + pointer = get_stack_frame( pointer )->previous; + } + } +} + +/** + * Fetch a pointer to the value of the local variable at this index. + */ +struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int index ) { + struct cons_pointer result = NIL; + + if ( index < args_in_frame ) { + result = frame->arg[index]; + } else { + struct cons_pointer p = frame->more; + + for ( int i = args_in_frame; i < index; i++ ) { + p = pointer2cell( p ).payload.cons.cdr; + } + + result = pointer2cell( p ).payload.cons.car; + } + + return result; +} diff --git a/src/stack.h b/src/memory/stack.h similarity index 59% rename from src/stack.h rename to src/memory/stack.h index ebb1aa1..79cd1e2 100644 --- a/src/stack.h +++ b/src/memory/stack.h @@ -25,38 +25,41 @@ #define __stack_h /** - * Make an empty stack frame, and return it. - * @param previous the current top-of-stack; - * @param env the environment in which evaluation happens. - * @return the new frame. + * macros for the tag of a stack frame. */ -struct stack_frame *make_empty_frame( struct stack_frame *previous, - struct cons_pointer env ); - -struct stack_frame *make_stack_frame( struct stack_frame *previous, - struct cons_pointer args, - struct cons_pointer env, - struct cons_pointer *exception ); -void free_stack_frame( struct stack_frame *frame ); +#define STACKFRAMETAG "STAK" +#define STACKFRAMETV 1262572627 /** - * Dump a stackframe to this stream for debugging - * @param output the stream - * @param frame the frame + * is this vector-space object a stack frame? */ -void dump_frame( FILE * output, struct stack_frame *frame ); +#define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV) + +/** + * set a register in a stack frame. Alwaye use this macro to do so, + • because that way we can be sure the inc_ref happens! + */ +//#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);} + +void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value); + +struct stack_frame *get_stack_frame( struct cons_pointer pointer ); + +struct cons_pointer make_empty_frame( struct cons_pointer previous ); + +struct cons_pointer make_stack_frame( struct cons_pointer previous, + struct cons_pointer args, + struct cons_pointer env ); + +void free_stack_frame( struct stack_frame *frame ); + +void dump_frame( FILE * output, struct cons_pointer pointer ); + +void dump_stack_trace( FILE * output, struct cons_pointer frame_pointer ); struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n ); -/** - * A 'special' frame is exactly like a normal stack frame except that the - * arguments are unevaluated. - * @param previous the previous stack frame; - * @param args a list of the arguments to be stored in this stack frame; - * @param env the execution environment; - * @return a new special frame. - */ -struct stack_frame *make_special_frame( struct stack_frame *previous, +struct cons_pointer make_special_frame( struct cons_pointer previous, struct cons_pointer args, struct cons_pointer env ); diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c new file mode 100644 index 0000000..c30f120 --- /dev/null +++ b/src/memory/vectorspace.c @@ -0,0 +1,97 @@ +/* + * vectorspace.c + * + * Structures common to all vector space objects. + * + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#include "conspage.h" +#include "consspaceobject.h" +#include "debug.h" +#include "vectorspace.h" + + +/** + * make a cons-space object which points to the vector space object + * with this `tag` at this `address`. + * NOTE that `tag` should be the vector-space tag of the particular type of + * vector-space object, NOT `VECTORPOINTTAG`. + */ +struct cons_pointer make_vec_pointer( struct vector_space_object *address ) { + debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC ); + struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); + struct cons_space_object *cell = &pointer2cell( pointer ); + debug_printf( DEBUG_ALLOC, + L"make_vec_pointer: tag written, about to set pointer address to %p\n", + address ); + cell->payload.vectorp.address = address; + debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n", + cell->payload.vectorp.address ); + + debug_dump_object( pointer, DEBUG_ALLOC ); + + return pointer; +} + +/** + * allocate a vector space object with this `payload_size` and `tag`, + * and return a `cons_pointer` which points to an object whigh points to it. + * NOTE that `tag` should be the vector-space tag of the particular type of + * vector-space object, NOT `VECTORPOINTTAG`. + * Returns NIL if the vector could not be allocated due to memory exhaustion. + */ +struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { + debug_print( L"Entered make_vso\n", DEBUG_ALLOC ); + struct cons_pointer result = NIL; + int64_t total_size = sizeof( struct vector_space_header ) + payload_size; + + /* Pad size to 64 bit words. This is intended to promote access efficiancy + * on 64 bit machines but may just be voodoo coding */ + uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 ); + debug_print( L"make_vso: about to malloc\n", DEBUG_ALLOC ); + struct vector_space_object *vso = malloc( padded ); + + if ( vso != NULL ) { + debug_printf( DEBUG_ALLOC, + L"make_vso: about to write tag '%s' into vso at %p\n", tag, + vso ); + strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH ); + result = make_vec_pointer( vso ); + debug_dump_object( result, DEBUG_ALLOC ); + vso->header.vecp = result; + // memcpy(vso->header.vecp, result, sizeof(struct cons_pointer)); + + vso->header.size = payload_size; + +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, + L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n", + &vso->header.tag.bytes, total_size, vso->header.size, vso, + &vso->payload ); + if ( padded != total_size ) { + debug_printf( DEBUG_ALLOC, L"\t\tPadded from %d to %d\n", + total_size, padded ); + } +#endif + } +#ifdef DEBUG + debug_printf( DEBUG_ALLOC, L"make_vso: all good, returning pointer to %p\n", + pointer2cell( result ).payload.vectorp.address ); +#endif + + return result; +} diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h new file mode 100644 index 0000000..1438d37 --- /dev/null +++ b/src/memory/vectorspace.h @@ -0,0 +1,71 @@ +/** + * vectorspace.h + * + * Declarations common to all vector space objects. + * + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#include "consspaceobject.h" + +#ifndef __vectorspace_h +#define __vectorspace_h + +/* + * part of the implementation structure of a namespace. + */ +#define HASHTAG "HASH" +#define HASHTV 0 + +/* + * a namespace (i.e. a binding of names to values, implemented as a hashmap) + */ +#define NAMESPACETAG "NMSP" +#define NAMESPACETV 0 + +/* + * a vector of cons pointers. + */ +#define VECTORTAG "VECT" +#define VECTORTV 0 + +#define pointer_to_vso(pointer)((vectorpointp(pointer)? (struct vector_space_object *) pointer2cell(pointer).payload.vectorp.address : (struct vector_space_object *) NULL)) +#define vso_get_vecp(vso)((vso->header.vecp)) + +struct cons_pointer make_vso( char *tag, uint64_t payload_size ); + +struct vector_space_header { + union { + char bytes[TAGLENGTH]; /* the tag (type) of the + * vector-space object this cell + * points to, considered as bytes. + * NOTE that the vector space object + * should itself have the identical + * tag. */ + uint32_t value; /* the tag considered as a number */ + } tag; + struct cons_pointer vecp; /* back pointer to the vector pointer + * which uniquely points to this vso */ + uint64_t size; /* the size of my payload, in bytes */ +}; + +struct vector_space_object { + struct vector_space_header header; + char payload; /* we'll malloc `size` bytes for payload, + * `payload` is just the first of these. + * TODO: this is almost certainly not + * idiomatic C. */ +}; + +#endif diff --git a/src/equal.c b/src/ops/equal.c similarity index 98% rename from src/equal.c rename to src/ops/equal.c index ebb085e..0f0597c 100644 --- a/src/equal.c +++ b/src/ops/equal.c @@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { && ( equal( cell_a->payload.string.cdr, cell_b->payload.string.cdr ) || ( end_of_string( cell_a->payload.string.cdr ) - && end_of_string( cell_b->payload.string. - cdr ) ) ); + && end_of_string( cell_b->payload. + string.cdr ) ) ); break; case INTEGERTV: result = diff --git a/src/equal.h b/src/ops/equal.h similarity index 100% rename from src/equal.h rename to src/ops/equal.h diff --git a/src/intern.c b/src/ops/intern.c similarity index 81% rename from src/intern.c rename to src/ops/intern.c index 100589a..27c745d 100644 --- a/src/intern.c +++ b/src/ops/intern.c @@ -21,6 +21,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "debug.h" #include "equal.h" #include "lispops.h" #include "print.h" @@ -56,22 +57,22 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { struct cons_space_object entry = pointer2cell( pointer2cell( next ).payload.cons.car ); - fputws( L"Internedp: checking whether `", stderr ); - print( stderr, key ); - fputws( L"` equals `", stderr ); - print( stderr, entry.payload.cons.car ); - fputws( L"`\n", stderr ); + debug_print( L"Internedp: checking whether `", DEBUG_ALLOC ); + debug_print_object( key, DEBUG_ALLOC ); + debug_print( L"` equals `", DEBUG_ALLOC ); + debug_print_object( entry.payload.cons.car, DEBUG_ALLOC ); + debug_print( L"`\n", DEBUG_ALLOC ); if ( equal( key, entry.payload.cons.car ) ) { result = entry.payload.cons.car; } } } else { - fputws( L"`", stderr ); - print( stderr, key ); - fputws( L"` is a ", stderr ); - print( stderr, c_type( key ) ); - fputws( L", not a SYMB", stderr ); + debug_print( L"`", DEBUG_ALLOC ); + debug_print_object( key, DEBUG_ALLOC ); + debug_print( L"` is a ", DEBUG_ALLOC ); + debug_print_object( c_type( key ), DEBUG_ALLOC ); + debug_print( L", not a SYMB", DEBUG_ALLOC ); } return result; @@ -110,6 +111,12 @@ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer bind( struct cons_pointer key, struct cons_pointer value, struct cons_pointer store ) { + debug_print(L"Binding ", DEBUG_ALLOC); + debug_print_object(key, DEBUG_ALLOC); + debug_print(L" to ", DEBUG_ALLOC); + debug_print_object(value, DEBUG_ALLOC); + debug_println(DEBUG_ALLOC); + return make_cons( make_cons( key, value ), store ); } @@ -120,7 +127,17 @@ bind( struct cons_pointer key, struct cons_pointer value, */ struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ) { + debug_print( L"Entering deep_bind\n", DEBUG_ALLOC ); + debug_print( L"\tSetting ", DEBUG_ALLOC ); + debug_print_object( key, DEBUG_ALLOC ); + debug_print( L" to ", DEBUG_ALLOC ); + debug_print_object( value, DEBUG_ALLOC ); + debug_print( L"\n", DEBUG_ALLOC ); + oblist = bind( key, value, oblist ); + + debug_print( L"Leaving deep_bind\n", DEBUG_ALLOC ); + return oblist; } diff --git a/src/intern.h b/src/ops/intern.h similarity index 100% rename from src/intern.h rename to src/ops/intern.h diff --git a/src/lispops.c b/src/ops/lispops.c similarity index 58% rename from src/lispops.c rename to src/ops/lispops.c index 62338b1..82746e0 100644 --- a/src/lispops.c +++ b/src/ops/lispops.c @@ -26,6 +26,8 @@ #include "consspaceobject.h" #include "conspage.h" +#include "debug.h" +#include "dump.h" #include "equal.h" #include "integer.h" #include "intern.h" @@ -80,23 +82,27 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) { * @return the result of evaluating the form. */ struct cons_pointer eval_form( struct stack_frame *parent, + struct cons_pointer parent_pointer, struct cons_pointer form, struct cons_pointer env ) { - fputws( L"eval_form: ", stderr ); - print( stderr, form ); - fputws( L"\n", stderr ); + debug_print( L"eval_form: ", DEBUG_EVAL ); + debug_dump_object( form, DEBUG_EVAL ); struct cons_pointer result = NIL; - struct stack_frame *next = make_empty_frame( parent, env ); - next->arg[0] = form; - inc_ref( next->arg[0] ); - result = lisp_eval( next, env ); + struct cons_pointer next_pointer = make_empty_frame( parent_pointer ); + inc_ref( next_pointer ); + + struct stack_frame *next = get_stack_frame( next_pointer ); + set_reg( next, 0, form ); + next->args = 1; + + result = lisp_eval( next, next_pointer, env ); if ( !exceptionp( result ) ) { /* if we're returning an exception, we should NOT free the * stack frame. Corollary is, when we free an exception, we * should free all the frames it's holding on to. */ - free_stack_frame( next ); + dec_ref( next_pointer ); } return result; @@ -108,11 +114,14 @@ struct cons_pointer eval_form( struct stack_frame *parent, * `list` is not in fact a list, return nil. */ struct cons_pointer eval_forms( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer list, struct cons_pointer env ) { + /* TODO: refactor. This runs up the C stack. */ return consp( list ) ? - make_cons( eval_form( frame, c_car( list ), env ), - eval_forms( frame, c_cdr( list ), env ) ) : NIL; + make_cons( eval_form( frame, frame_pointer, c_car( list ), env ), + eval_forms( frame, frame_pointer, c_cdr( list ), + env ) ) : NIL; } /** @@ -121,7 +130,8 @@ struct cons_pointer eval_forms( struct stack_frame *frame, * (oblist) */ struct cons_pointer -lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) { +lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { return oblist; } @@ -130,8 +140,7 @@ lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) { * used to construct the body for `lambda` and `nlambda` expressions. */ struct cons_pointer compose_body( struct stack_frame *frame ) { - struct cons_pointer body = - !nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL; + struct cons_pointer body = frame->more; for ( int i = args_in_frame - 1; i > 0; i-- ) { if ( !nilp( body ) ) { @@ -141,9 +150,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) { } } - fputws( L"compose_body returning ", stderr ); - print( stderr, body ); - fputws( L"\n", stderr ); + debug_print( L"compose_body returning ", DEBUG_LAMBDA ); + debug_dump_object( body, DEBUG_LAMBDA ); return body; } @@ -155,7 +163,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) { * @param env the environment in which it is to be intepreted. */ struct cons_pointer -lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) { +lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { return make_lambda( frame->arg[0], compose_body( frame ) ); } @@ -166,16 +175,16 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) { * @param env the environment in which it is to be intepreted. */ struct cons_pointer -lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ) { +lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { return make_nlambda( frame->arg[0], compose_body( frame ) ); } void log_binding( struct cons_pointer name, struct cons_pointer val ) { - print( stderr, c_string_to_lisp_string( "\n\tBinding " ) ); - print( stderr, name ); - print( stderr, c_string_to_lisp_string( " to " ) ); - print( stderr, val ); - fputws( L"\"\n", stderr ); + debug_print( L"\n\tBinding ", DEBUG_ALLOC ); + debug_dump_object( name, DEBUG_ALLOC ); + debug_print( L" to ", DEBUG_ALLOC ); + debug_dump_object( val, DEBUG_ALLOC ); } /** @@ -183,9 +192,9 @@ void log_binding( struct cons_pointer name, struct cons_pointer val ) { */ struct cons_pointer eval_lambda( struct cons_space_object cell, struct stack_frame *frame, - struct cons_pointer env ) { + struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; - fwprintf( stderr, L"eval_lambda called\n" ); + debug_print( L"eval_lambda called\n", DEBUG_EVAL ); struct cons_pointer new_env = env; struct cons_pointer names = cell.payload.lambda.args; @@ -194,7 +203,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, if ( consp( names ) ) { /* if `names` is a list, bind successive items from that list * to values of arguments */ - for ( int i = 0; i < args_in_frame && consp( names ); i++ ) { + for ( int i = 0; i < frame->args && consp( names ); i++ ) { struct cons_pointer name = c_car( names ); struct cons_pointer val = frame->arg[i]; @@ -203,13 +212,16 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, names = c_cdr( names ); } + /* TODO: if there's more than `args_in_frame` arguments, bind those too. */ } else if ( symbolp( names ) ) { /* if `names` is a symbol, rather than a list of symbols, * then bind a list of the values of args to that symbol. */ + /* TODO: eval all the things in frame->more */ struct cons_pointer vals = frame->more; for ( int i = args_in_frame - 1; i >= 0; i-- ) { - struct cons_pointer val = eval_form( frame, frame->arg[i], env ); + struct cons_pointer val = + eval_form( frame, frame_pointer, frame->arg[i], env ); if ( nilp( val ) && nilp( vals ) ) { /* nothing */ } else { @@ -223,8 +235,10 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, while ( !nilp( body ) ) { struct cons_pointer sexpr = c_car( body ); body = c_cdr( body ); - fputws( L"In lambda: ", stderr ); - result = eval_form( frame, sexpr, new_env ); + + debug_print( L"In lambda: ", DEBUG_LAMBDA ); + + result = eval_form( frame, frame_pointer, sexpr, new_env ); } return result; @@ -239,20 +253,17 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, * @return the result of evaluating the function with its arguments. */ struct cons_pointer -c_apply( struct stack_frame *frame, struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct stack_frame *fn_frame = make_empty_frame( frame, env ); - fn_frame->arg[0] = c_car( frame->arg[0] ); - inc_ref( fn_frame->arg[0] ); - struct cons_pointer fn_pointer = lisp_eval( fn_frame, env ); +c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print(L"Entering c_apply\n", DEBUG_EVAL); + struct cons_pointer result = NIL; - if ( !exceptionp( result ) ) { - /* if we're returning an exception, we should NOT free the - * stack frame. Corollary is, when we free an exception, we - * should free all the frames it's holding on to. */ - free_stack_frame( fn_frame ); - } + struct cons_pointer fn_pointer = + eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env ); + if ( exceptionp( fn_pointer ) ) { + result = fn_pointer; + } else { struct cons_space_object fn_cell = pointer2cell( fn_pointer ); struct cons_pointer args = c_cdr( frame->arg[0] ); @@ -264,80 +275,92 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { case FUNCTIONTV: { struct cons_pointer exep = NIL; - struct stack_frame *next = - make_stack_frame( frame, args, env, &exep ); - result = ( *fn_cell.payload.special.executable ) ( next, env ); - if ( exceptionp( exep ) ) { - /* if we're returning an exception, we should NOT free the - * stack frame. Corollary is, when we free an exception, we - * should free all the frames it's holding on to. */ - result = exep; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; } else { - free_stack_frame( next ); + struct stack_frame *next = get_stack_frame( next_pointer ); + + result = + ( *fn_cell.payload.function.executable ) ( next, + next_pointer, + env ); + dec_ref( next_pointer ); } } break; case LAMBDATV: { struct cons_pointer exep = NIL; - struct stack_frame *next = - make_stack_frame( frame, args, env, &exep ); - fputws( L"Stack frame for lambda\n", stderr ); - dump_frame( stderr, next ); - result = eval_lambda( fn_cell, next, env ); - if ( exceptionp( result ) ) { - /* if we're returning an exception, we should NOT free the - * stack frame. Corollary is, when we free an exception, we - * should free all the frames it's holding on to. */ - result = exep; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; } else { - free_stack_frame( next ); + struct stack_frame *next = get_stack_frame( next_pointer ); + result = eval_lambda( fn_cell, next, next_pointer, env ); + if ( !exceptionp( result ) ) { + dec_ref( next_pointer ); + } } } break; case NLAMBDATV: { - struct stack_frame *next = - make_special_frame( frame, args, env ); - fputws( L"Stack frame for nlambda\n", stderr ); - dump_frame( stderr, next ); - result = eval_lambda( fn_cell, next, env ); - if ( !exceptionp( result ) ) { - /* if we're returning an exception, we should NOT free the - * stack frame. Corollary is, when we free an exception, we - * should free all the frames it's holding on to. */ - free_stack_frame( next ); + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = eval_lambda( fn_cell, next, next_pointer, env ); + dec_ref( next_pointer ); } } break; case SPECIALTV: { - struct stack_frame *next = - make_special_frame( frame, args, env ); - result = ( *fn_cell.payload.special.executable ) ( next, env ); - if ( !exceptionp( result ) ) { - /* if we're returning an exception, we should NOT free the - * stack frame. Corollary is, when we free an exception, we - * should free all the frames it's holding on to. */ - free_stack_frame( next ); + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + result = + ( *fn_cell.payload.special.executable ) ( get_stack_frame( next_pointer ), + next_pointer, + env ); + debug_print(L"Special form returning: ", DEBUG_EVAL); + debug_print_object(result, DEBUG_EVAL); + debug_println(DEBUG_EVAL); + dec_ref( next_pointer ); } } break; default: { - char *buffer = malloc( 1024 ); - memset( buffer, '\0', 1024 ); - sprintf( buffer, - "Unexpected cell with tag %d (%c%c%c%c) in function position", - fn_cell.tag.value, fn_cell.tag.bytes[0], - fn_cell.tag.bytes[1], fn_cell.tag.bytes[2], - fn_cell.tag.bytes[3] ); + int bs = sizeof(wchar_t) * 1024; + wchar_t *buffer = malloc( bs ); + memset( buffer, '\0', bs ); + swprintf( buffer, bs, + L"Unexpected cell with tag %d (%4.4s) in function position", + fn_cell.tag.value, &fn_cell.tag.bytes[0] ); struct cons_pointer message = c_string_to_lisp_string( buffer ); free( buffer ); - result = lisp_throw( message, frame ); + result = throw_exception( message, frame_pointer ); } } + } + + debug_print(L"c_apply: returning: ", DEBUG_EVAL); + debug_print_object(result, DEBUG_EVAL); + debug_println(DEBUG_EVAL); return result; } @@ -349,13 +372,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) { * @return As a Lisp string, the tag of the object which is at that pointer. */ struct cons_pointer c_type( struct cons_pointer pointer ) { - char *buffer = malloc( TAGLENGTH + 1 ); - memset( buffer, 0, TAGLENGTH + 1 ); + struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( pointer ); - strncpy( buffer, cell.tag.bytes, TAGLENGTH ); - struct cons_pointer result = c_string_to_lisp_string( buffer ); - free( buffer ); + for (int i = TAGLENGTH; i >= 0; i--) + { + result = make_string((wchar_t)cell.tag.bytes[i], result); + } return result; } @@ -375,17 +398,18 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { * If a special form, passes the cdr of s_expr to the special form as argument. */ struct cons_pointer -lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { +lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Eval: ", DEBUG_EVAL ); + debug_dump_object( frame_pointer, DEBUG_EVAL ); + struct cons_pointer result = frame->arg[0]; struct cons_space_object cell = pointer2cell( frame->arg[0] ); - fputws( L"Eval: ", stderr ); - dump_frame( stderr, frame ); - switch ( cell.tag.value ) { case CONSTV: { - result = c_apply( frame, env ); + result = c_apply( frame, frame_pointer, env ); } break; @@ -396,9 +420,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { if ( nilp( canonical ) ) { struct cons_pointer message = make_cons( c_string_to_lisp_string - ( "Attempt to take value of unbound symbol." ), + ( L"Attempt to take value of unbound symbol." ), frame->arg[0] ); - result = lisp_throw( message, frame ); + result = throw_exception( message, frame_pointer ); } else { result = c_assoc( canonical, env ); inc_ref( result ); @@ -418,9 +442,8 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { break; } - fputws( L"Eval returning ", stderr ); - print( stderr, result ); - fputws( L"\n", stderr ); + debug_print( L"Eval returning ", DEBUG_EVAL ); + debug_dump_object( result, DEBUG_EVAL ); return result; } @@ -434,19 +457,19 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { * the second argument */ struct cons_pointer -lisp_apply( struct stack_frame *frame, struct cons_pointer env ) { - fputws( L"Apply: ", stderr ); - dump_frame( stderr, frame ); +lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { +#ifdef DEBUG + debug_print( L"Apply: ", DEBUG_EVAL ); + dump_frame( stderr, frame_pointer ); +#endif + set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); + set_reg( frame, 1, NIL ); - frame->arg[0] = make_cons( frame->arg[0], frame->arg[1] ); - inc_ref( frame->arg[0] ); - frame->arg[1] = NIL; + struct cons_pointer result = c_apply( frame, frame_pointer, env ); - struct cons_pointer result = c_apply( frame, env ); - - fputws( L"Apply returning ", stderr ); - print( stderr, result ); - fputws( L"\n", stderr ); + debug_print( L"Apply returning ", DEBUG_EVAL ); + debug_dump_object( result, DEBUG_EVAL ); return result; } @@ -460,7 +483,8 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer env ) { * this isn't at this stage checked) unevaluated. */ struct cons_pointer -lisp_quote( struct stack_frame *frame, struct cons_pointer env ) { +lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { return frame->arg[0]; } @@ -475,7 +499,8 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer env ) { * the namespace in so doing. `namespace` defaults to the value of `oblist`. */ struct cons_pointer -lisp_set( struct stack_frame *frame, struct cons_pointer env ) { +lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { struct cons_pointer result = NIL; struct cons_pointer namespace = nilp( frame->arg[2] ) ? oblist : frame->arg[2]; @@ -487,8 +512,9 @@ lisp_set( struct stack_frame *frame, struct cons_pointer env ) { result = make_exception( make_cons ( c_string_to_lisp_string - ( "The first argument to `set!` is not a symbol: " ), - make_cons( frame->arg[0], NIL ) ), frame ); + ( L"The first argument to `set` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), + frame_pointer ); } return result; @@ -505,21 +531,24 @@ lisp_set( struct stack_frame *frame, struct cons_pointer env ) { * the namespace in so doing. `namespace` defaults to the value of `oblist`. */ struct cons_pointer -lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) { +lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { struct cons_pointer result = NIL; struct cons_pointer namespace = nilp( frame->arg[2] ) ? oblist : frame->arg[2]; if ( symbolp( frame->arg[0] ) ) { - struct cons_pointer val = eval_form( frame, frame->arg[1], env ); + struct cons_pointer val = + eval_form( frame, frame_pointer, frame->arg[1], env ); deep_bind( frame->arg[0], val ); result = val; } else { result = make_exception( make_cons ( c_string_to_lisp_string - ( "The first argument to `set!` is not a symbol: " ), - make_cons( frame->arg[0], NIL ) ), frame ); + ( L"The first argument to `set!` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), + frame_pointer ); } return result; @@ -534,7 +563,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) { * otherwise returns a new cons cell. */ struct cons_pointer -lisp_cons( struct stack_frame *frame, struct cons_pointer env ) { +lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { struct cons_pointer car = frame->arg[0]; struct cons_pointer cdr = frame->arg[1]; struct cons_pointer result; @@ -558,7 +588,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer env ) { * strings, and TODO read streams and other things which can be considered as sequences. */ struct cons_pointer -lisp_car( struct stack_frame *frame, struct cons_pointer env ) { +lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { struct cons_pointer result = NIL; if ( consp( frame->arg[0] ) ) { @@ -569,8 +600,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) { result = make_string( cell.payload.string.character, NIL ); } else { struct cons_pointer message = - c_string_to_lisp_string( "Attempt to take CAR of non sequence" ); - result = lisp_throw( message, frame ); + c_string_to_lisp_string( L"Attempt to take CAR of non sequence" ); + result = throw_exception( message, frame_pointer ); } return result; @@ -582,7 +613,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) { * strings, and TODO read streams and other things which can be considered as sequences. */ struct cons_pointer -lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) { +lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { struct cons_pointer result = NIL; if ( consp( frame->arg[0] ) ) { @@ -593,8 +625,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) { result = cell.payload.string.cdr; } else { struct cons_pointer message = - c_string_to_lisp_string( "Attempt to take CDR of non sequence" ); - result = lisp_throw( message, frame ); + c_string_to_lisp_string( L"Attempt to take CDR of non sequence" ); + result = throw_exception( message, frame_pointer ); } return result; @@ -605,7 +637,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) { * Returns the value associated with key in store, or NIL if not found. */ struct cons_pointer -lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) { +lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { return c_assoc( frame->arg[0], frame->arg[1] ); } @@ -614,6 +647,7 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) { * Returns T if a and b are pointers to the same object, else NIL */ struct cons_pointer lisp_eq( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ) { return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; } @@ -623,7 +657,8 @@ struct cons_pointer lisp_eq( struct stack_frame *frame, * Returns T if a and b are pointers to structurally identical objects, else NIL */ struct cons_pointer -lisp_equal( struct stack_frame *frame, struct cons_pointer env ) { +lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; } @@ -634,14 +669,58 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer env ) { * is a read stream, then read from that stream, else stdin. */ struct cons_pointer -lisp_read( struct stack_frame *frame, struct cons_pointer env ) { +lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { +#ifdef DEBUG + debug_print( L"entering lisp_read\n", DEBUG_IO ); +#endif FILE *input = stdin; if ( readp( frame->arg[0] ) ) { input = pointer2cell( frame->arg[0] ).payload.stream.stream; } - return read( frame, input ); + struct cons_pointer result = read( frame, frame_pointer, input ); + debug_print( L"lisp_read returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + + return result; +} + + +/** + * reverse a sequence. + */ +struct cons_pointer c_reverse( struct cons_pointer arg ) { + struct cons_pointer result = NIL; + + for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) { + struct cons_space_object o = pointer2cell( p ); + switch ( o.tag.value ) { + case CONSTV: + result = make_cons( o.payload.cons.car, result ); + break; + case STRINGTV: + result = make_string( o.payload.string.character, result ); + break; + case SYMBOLTV: + result = make_symbol( o.payload.string.character, result ); + break; + } + } + + return result; +} + + +/** + * (reverse sequence) + * Return a sequence like this sequence but with the members in the reverse order. + */ +struct cons_pointer lisp_reverse( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return c_reverse( frame->arg[0] ); } @@ -652,16 +731,26 @@ lisp_read( struct stack_frame *frame, struct cons_pointer env ) { * is a write stream, then print to that stream, else stdout. */ struct cons_pointer -lisp_print( struct stack_frame *frame, struct cons_pointer env ) { +lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Entering print\n", DEBUG_IO ); + struct cons_pointer result = NIL; FILE *output = stdout; if ( writep( frame->arg[1] ) ) { + debug_print( L"lisp_print: setting output stream\n", DEBUG_IO ); + debug_dump_object( frame->arg[1], DEBUG_IO ); output = pointer2cell( frame->arg[1] ).payload.stream.stream; } + debug_print( L"lisp_print: about to print\n", DEBUG_IO ); + debug_dump_object( frame->arg[0], DEBUG_IO ); - print( output, frame->arg[0] ); + result = print( output, frame->arg[0] ); - return NIL; + debug_print( L"lisp_print returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + + return result; } @@ -672,7 +761,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) { * @return As a Lisp string, the tag of the object which is the argument. */ struct cons_pointer -lisp_type( struct stack_frame *frame, struct cons_pointer env ) { +lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { return c_type( frame->arg[0] ); } @@ -690,16 +780,17 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) { * argument. */ struct cons_pointer -lisp_progn( struct stack_frame *frame, struct cons_pointer env ) { +lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { struct cons_pointer remaining = frame->more; struct cons_pointer result = NIL; for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { - result = eval_form( frame, frame->arg[i], env ); + result = eval_form( frame, frame_pointer, frame->arg[i], env ); } while ( consp( remaining ) ) { - result = eval_form( frame, c_car( remaining ), env ); + result = eval_form( frame, frame_pointer, c_car( remaining ), env ); remaining = c_cdr( remaining ); } @@ -717,22 +808,26 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env ) { * @return the value of the last form of the first successful clause. */ struct cons_pointer -lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { +lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { struct cons_pointer result = NIL; bool done = false; for ( int i = 0; i < args_in_frame && !done; i++ ) { struct cons_pointer clause_pointer = frame->arg[i]; - fputws( L"Cond clause: ", stderr ); - print( stderr, clause_pointer ); + debug_print( L"Cond clause: ", DEBUG_EVAL ); + debug_dump_object( clause_pointer, DEBUG_EVAL ); if ( consp( clause_pointer ) ) { struct cons_space_object cell = pointer2cell( clause_pointer ); - result = eval_form( frame, c_car( clause_pointer ), env ); + result = + eval_form( frame, frame_pointer, c_car( clause_pointer ), + env ); if ( !nilp( result ) ) { struct cons_pointer vals = - eval_forms( frame, c_cdr( clause_pointer ), env ); + eval_forms( frame, frame_pointer, c_cdr( clause_pointer ), + env ); while ( consp( vals ) ) { result = c_car( vals ); @@ -744,9 +839,9 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { } else if ( nilp( clause_pointer ) ) { done = true; } else { - result = lisp_throw( c_string_to_lisp_string - ( "Arguments to `cond` must be lists" ), - frame ); + result = throw_exception( c_string_to_lisp_string + ( L"Arguments to `cond` must be lists" ), + frame_pointer ); } } /* TODO: if there are more than 8 clauses we need to continue into the @@ -756,17 +851,20 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) { } /** - * TODO: make this do something sensible somehow. - * This requires that a frame be a heap-space object with a cons-space + * Throw an exception. + * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a + * lisp function; but it is nevertheless to be preferred to make_exception. A + * real `throw_exception`, which does, will be needed. * object pointing to it. Then this should become a normal lisp function * which expects a normally bound frame and environment, such that * frame->arg[0] is the message, and frame->arg[1] is the cons-space * pointer to the frame in which the exception occurred. */ struct cons_pointer -lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { - fwprintf( stderr, L"\nERROR: " ); - print( stderr, message ); +throw_exception( struct cons_pointer message, + struct cons_pointer frame_pointer ) { + debug_print( L"\nERROR: ", DEBUG_EVAL ); + debug_dump_object( message, DEBUG_EVAL ); struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( message ); @@ -774,8 +872,25 @@ lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { if ( cell.tag.value == EXCEPTIONTV ) { result = message; } else { - result = make_exception( message, frame ); + result = make_exception( message, frame_pointer ); } return result; } + +/** + * (exception ) + * + * Function. Returns an exception whose message is this `message`, and whose + * stack frame is the parent stack frame when the function is invoked. + * `message` does not have to be a string but should be something intelligible + * which can be read. + * If `message` is itself an exception, returns that instead. + */ +struct cons_pointer +lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer message = frame->arg[0]; + return exceptionp( message ) ? message : make_exception( message, + frame->previous ); +} diff --git a/src/lispops.h b/src/ops/lispops.h similarity index 67% rename from src/lispops.h rename to src/ops/lispops.h index 122e149..a1dee81 100644 --- a/src/lispops.h +++ b/src/ops/lispops.h @@ -40,6 +40,7 @@ struct cons_pointer c_car( struct cons_pointer arg ); */ struct cons_pointer c_cdr( struct cons_pointer arg ); +struct cons_pointer c_reverse( struct cons_pointer arg ); /** * Useful building block; evaluate this single form in the context of this @@ -50,6 +51,7 @@ struct cons_pointer c_cdr( struct cons_pointer arg ); * @return the result of evaluating the form. */ struct cons_pointer eval_form( struct stack_frame *parent, + struct cons_pointer parent_pointer, struct cons_pointer form, struct cons_pointer env ); @@ -59,6 +61,7 @@ struct cons_pointer eval_form( struct stack_frame *parent, * `list` is not in fact a list, return nil. */ struct cons_pointer eval_forms( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer list, struct cons_pointer env ); @@ -67,18 +70,23 @@ struct cons_pointer eval_forms( struct stack_frame *frame, * special forms */ struct cons_pointer lisp_eval( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_apply( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer -lisp_oblist( struct stack_frame *frame, struct cons_pointer env ); +lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer -lisp_set( struct stack_frame *frame, struct cons_pointer env ); +lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer -lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ); +lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Construct an interpretable function. @@ -88,6 +96,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ); * @param env the environment in which it is to be intepreted. */ struct cons_pointer lisp_lambda( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); /** @@ -97,30 +106,43 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame, * @param env the environment in which it is to be intepreted. */ struct cons_pointer -lisp_nlambda( struct stack_frame *frame, struct cons_pointer env ); +lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_quote( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); /* * functions */ struct cons_pointer lisp_cons( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_car( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_cdr( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_assoc( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_eq( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_equal( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer lisp_print( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_read( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_print( struct stack_frame *frame, - struct cons_pointer env ); +struct cons_pointer lisp_reverse( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Function: Get the Lisp type of the single argument. * @param frame My stack frame. @@ -128,7 +150,8 @@ struct cons_pointer lisp_print( struct stack_frame *frame, * @return As a Lisp string, the tag of the object which is the argument. */ struct cons_pointer -lisp_type( struct stack_frame *frame, struct cons_pointer env ); +lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); /** @@ -142,7 +165,8 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ); * argument. */ struct cons_pointer -lisp_progn( struct stack_frame *frame, struct cons_pointer env ); +lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Special form: conditional. Each arg is expected to be a list; if the first @@ -154,10 +178,18 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env ); * @return the value of the last form of the first successful clause. */ struct cons_pointer -lisp_cond( struct stack_frame *frame, struct cons_pointer env ); +lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); -/* - * neither, at this stage, really +/** + * Throw an exception. + * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a + * lisp function; but it is nevertheless to be preferred to make_exception. A + * real `throw_exception`, which does, will be needed. */ -struct cons_pointer lisp_throw( struct cons_pointer message, - struct stack_frame *frame ); +struct cons_pointer throw_exception( struct cons_pointer message, + struct cons_pointer frame_pointer ); + +struct cons_pointer +lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); diff --git a/src/print.c b/src/ops/print.c similarity index 86% rename from src/print.c rename to src/ops/print.c index 42bf8b4..49adca7 100644 --- a/src/print.c +++ b/src/ops/print.c @@ -20,6 +20,7 @@ #include "conspage.h" #include "consspaceobject.h" #include "integer.h" +#include "stack.h" #include "print.h" /** @@ -36,7 +37,7 @@ int print_use_colours = 0; void print_string_contents( FILE * output, struct cons_pointer pointer ) { while ( stringp( pointer ) || symbolp( pointer ) ) { struct cons_space_object *cell = &pointer2cell( pointer ); - wint_t c = cell->payload.string.character; + wchar_t c = cell->payload.string.character; if ( c != '\0' ) { fputwc( c, output ); @@ -103,7 +104,7 @@ void print_list( FILE * output, struct cons_pointer pointer ) { * Print the cons-space object indicated by `pointer` to the stream indicated * by `output`. */ -void print( FILE * output, struct cons_pointer pointer ) { +struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); char *buffer; @@ -118,7 +119,7 @@ void print( FILE * output, struct cons_pointer pointer ) { case EXCEPTIONTV: fwprintf( output, L"\n%sException: ", print_use_colours ? "\x1B[31m" : "" ); - print_string_contents( output, cell.payload.exception.message ); + dump_stack_trace( output, pointer ); break; case FUNCTIONTV: fwprintf( output, L"(Function)" ); @@ -130,19 +131,24 @@ void print( FILE * output, struct cons_pointer pointer ) { fwprintf( output, L"%ld%", cell.payload.integer.value ); break; case LAMBDATV: - print( output, make_cons( c_string_to_lisp_symbol( "lambda" ), + print( output, make_cons( c_string_to_lisp_symbol( L"lambda" ), make_cons( cell.payload.lambda.args, - cell.payload. - lambda.body ) ) ); + cell.payload.lambda. + body ) ) ); break; case NILTV: fwprintf( output, L"nil" ); break; case NLAMBDATV: - print( output, make_cons( c_string_to_lisp_symbol( "nlambda" ), + print( output, make_cons( c_string_to_lisp_symbol( L"nlambda" ), make_cons( cell.payload.lambda.args, - cell.payload. - lambda.body ) ) ); + cell.payload.lambda. + body ) ) ); + break; + case RATIOTV: + print( output, cell.payload.ratio.dividend ); + fputws( L"/", output ); + print( output, cell.payload.ratio.divisor ); break; case READTV: fwprintf( output, L"(Input stream)" ); @@ -184,6 +190,9 @@ void print( FILE * output, struct cons_pointer pointer ) { case TRUETV: fwprintf( output, L"t" ); break; + case WRITETV: + fwprintf( output, L"(Output stream)" ); + break; default: fwprintf( stderr, L"%sError: Unrecognised tag value %d (%c%c%c%c)\n", @@ -196,4 +205,6 @@ void print( FILE * output, struct cons_pointer pointer ) { if ( print_use_colours ) { fputws( L"\x1B[39m", output ); } + + return pointer; } diff --git a/src/print.h b/src/ops/print.h similarity index 80% rename from src/print.h rename to src/ops/print.h index 7ee9c80..1399db4 100644 --- a/src/print.h +++ b/src/ops/print.h @@ -14,7 +14,7 @@ #ifndef __print_h #define __print_h -void print( FILE * output, struct cons_pointer pointer ); +struct cons_pointer print( FILE * output, struct cons_pointer pointer ); extern int print_use_colours; #endif diff --git a/src/read.c b/src/ops/read.c similarity index 53% rename from src/read.c rename to src/ops/read.c index 3bee19f..a9b1ffe 100644 --- a/src/read.c +++ b/src/ops/read.c @@ -18,12 +18,16 @@ #include #include "consspaceobject.h" +#include "debug.h" +#include "dump.h" #include "integer.h" #include "intern.h" #include "lispops.h" #include "print.h" +#include "ratio.h" #include "read.h" #include "real.h" +#include "vectorspace.h" /* * for the time being things which may be read are: strings numbers - either @@ -31,8 +35,12 @@ * atoms because I don't yet know what an atom is or how it's stored. */ -struct cons_pointer read_number( FILE * input, wint_t initial ); -struct cons_pointer read_list( struct stack_frame *frame, FILE * input, +struct cons_pointer read_number( struct stack_frame *frame, + struct cons_pointer frame_pointer, + FILE * input, wint_t initial, + bool seen_period ); +struct cons_pointer read_list( struct stack_frame *frame, + struct cons_pointer frame_pointer, FILE * input, wint_t initial ); struct cons_pointer read_string( FILE * input, wint_t initial ); struct cons_pointer read_symbol( FILE * input, wint_t initial ); @@ -41,7 +49,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ); * quote reader macro in C (!) */ struct cons_pointer c_quote( struct cons_pointer arg ) { - return make_cons( c_string_to_lisp_symbol( "quote" ), + return make_cons( c_string_to_lisp_symbol( L"quote" ), make_cons( arg, NIL ) ); } @@ -50,8 +58,10 @@ struct cons_pointer c_quote( struct cons_pointer arg ) { * treating this initial character as the first character of the object * representation. */ -struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, - wint_t initial ) { +struct cons_pointer read_continuation( struct stack_frame *frame, + struct cons_pointer frame_pointer, + FILE * input, wint_t initial ) { + debug_print( L"entering read_continuation\n", DEBUG_IO ); struct cons_pointer result = NIL; wint_t c; @@ -61,8 +71,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, if ( feof( input ) ) { result = - make_exception( c_string_to_lisp_string - ( "End of file while reading" ), frame ); + throw_exception( c_string_to_lisp_string + ( L"End of file while reading" ), frame_pointer ); } else { switch ( c ) { case ';': @@ -70,31 +80,49 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, /* skip all characters from semi-colon to the end of the line */ break; case EOF: - result = lisp_throw( c_string_to_lisp_string - ( "End of input while reading" ), frame ); + result = throw_exception( c_string_to_lisp_string + ( L"End of input while reading" ), + frame_pointer ); break; case '\'': result = c_quote( read_continuation - ( frame, input, fgetwc( input ) ) ); + ( frame, frame_pointer, input, + fgetwc( input ) ) ); break; case '(': - result = read_list( frame, input, fgetwc( input ) ); + result = + read_list( frame, frame_pointer, input, fgetwc( input ) ); break; case '"': result = read_string( input, fgetwc( input ) ); break; + case '-':{ + wint_t next = fgetwc( input ); + ungetwc( next, input ); + if ( iswdigit( next ) ) { + result = + read_number( frame, frame_pointer, input, c, + false ); + } else { + result = read_symbol( input, c ); + } + } + break; case '.': { wint_t next = fgetwc( input ); if ( iswdigit( next ) ) { ungetwc( next, input ); - result = read_number( input, c ); + result = + read_number( frame, frame_pointer, input, c, + true ); } else if ( iswblank( next ) ) { /* dotted pair. TODO: this isn't right, we * really need to backtrack up a level. */ result = - read_continuation( frame, input, fgetwc( input ) ); + read_continuation( frame, frame_pointer, input, + fgetwc( input ) ); } else { read_symbol( input, c ); } @@ -102,40 +130,76 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, break; default: if ( iswdigit( c ) ) { - result = read_number( input, c ); + result = + read_number( frame, frame_pointer, input, c, false ); } else if ( iswprint( c ) ) { result = read_symbol( input, c ); } else { result = - make_exception( c_string_to_lisp_string - ( "Unrecognised start of input character" ), - frame ); + throw_exception( make_cons( c_string_to_lisp_string + ( L"Unrecognised start of input character" ), + make_string( c, NIL ) ), + frame_pointer ); } + break; } } + debug_print( L"read_continuation returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); return result; } /** * read a number from this input stream, given this initial character. + * TODO: to be able to read bignums, we need to read the number from the + * input stream into a Lisp string, and then convert it to a number. */ -struct cons_pointer read_number( FILE * input, wint_t initial ) { +struct cons_pointer read_number( struct stack_frame *frame, + struct cons_pointer frame_pointer, + FILE * input, + wint_t initial, bool seen_period ) { + debug_print( L"entering read_number\n", DEBUG_IO ); struct cons_pointer result = NIL; - long int accumulator = 0; + int64_t accumulator = 0; + int64_t dividend = 0; int places_of_decimals = 0; - bool seen_period = false; wint_t c; - fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); + bool negative = initial == btowc( '-' ); + + if ( negative ) { + initial = fgetwc( input ); + } + + debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial ); + for ( c = initial; iswdigit( c ) - || c == btowc( '.' ); c = fgetwc( input ) ) { + || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) { if ( c == btowc( '.' ) ) { - seen_period = true; + if ( seen_period || dividend != 0 ) { + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: too many periods" ), + frame_pointer ); + } else { + seen_period = true; + } + } else if ( c == btowc( '/' ) ) { + if ( seen_period || dividend > 0 ) { + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: dividend of rational must be integer" ), + frame_pointer ); + } else { + dividend = negative ? 0 - accumulator : accumulator; + + accumulator = 0; + } } else { accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); - fwprintf( stderr, + + debug_printf( DEBUG_IO, L"Added character %c, accumulator now %ld\n", c, accumulator ); + if ( seen_period ) { places_of_decimals++; } @@ -149,12 +213,24 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) { if ( seen_period ) { long double rv = ( long double ) ( accumulator / pow( 10, places_of_decimals ) ); - fwprintf( stderr, L"read_numer returning %Lf\n", rv ); + if ( negative ) { + rv = 0 - rv; + } result = make_real( rv ); + } else if ( dividend != 0 ) { + result = + make_ratio( frame_pointer, make_integer( dividend ), + make_integer( accumulator ) ); } else { + if ( negative ) { + accumulator = 0 - accumulator; + } result = make_integer( accumulator ); } + debug_print( L"read_number returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + return result; } @@ -162,18 +238,22 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) { * Read a list from this input stream, which no longer contains the opening * left parenthesis. */ -struct cons_pointer read_list( struct - stack_frame - *frame, FILE * input, wint_t initial ) { +struct cons_pointer read_list( struct stack_frame *frame, + struct cons_pointer frame_pointer, + FILE * input, wint_t initial ) { struct cons_pointer result = NIL; if ( initial != ')' ) { - fwprintf( stderr, + debug_printf( DEBUG_IO, L"read_list starting '%C' (%d)\n", initial, initial ); - struct cons_pointer car = read_continuation( frame, input, - initial ); - result = make_cons( car, read_list( frame, input, fgetwc( input ) ) ); + struct cons_pointer car = + read_continuation( frame, frame_pointer, input, + initial ); + result = + make_cons( car, + read_list( frame, frame_pointer, input, + fgetwc( input ) ) ); } else { - fwprintf( stderr, L"End of list detected\n" ); + debug_print( L"End of list detected\n", DEBUG_IO ); } return result; @@ -245,9 +325,9 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { break; } - fputws( L"Read symbol '", stderr ); - print( stderr, result ); - fputws( L"'\n", stderr ); + debug_print( L"read_symbol returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + return result; } @@ -256,6 +336,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { */ struct cons_pointer read( struct stack_frame - *frame, FILE * input ) { - return read_continuation( frame, input, fgetwc( input ) ); + *frame, struct cons_pointer frame_pointer, + FILE * input ) { + return read_continuation( frame, frame_pointer, input, fgetwc( input ) ); } diff --git a/src/read.h b/src/ops/read.h similarity index 71% rename from src/read.h rename to src/ops/read.h index af7574b..c6dbba3 100644 --- a/src/read.h +++ b/src/ops/read.h @@ -14,6 +14,7 @@ /** * read the next object on this input stream and return a cons_pointer to it. */ -struct cons_pointer read( struct stack_frame *frame, FILE * input ); +struct cons_pointer read( struct stack_frame *frame, + struct cons_pointer frame_pointer, FILE * input ); #endif diff --git a/src/peano.c b/src/peano.c deleted file mode 100644 index 691c95f..0000000 --- a/src/peano.c +++ /dev/null @@ -1,237 +0,0 @@ -/* - * peano.c - * - * Basic peano arithmetic - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -#include -#include - -#include "consspaceobject.h" -#include "conspage.h" -#include "equal.h" -#include "integer.h" -#include "intern.h" -#include "lispops.h" -#include "print.h" -#include "read.h" -#include "real.h" -#include "stack.h" - -/** - * Internal guts of add. Dark and mysterious. - */ -struct cons_pointer add_accumulate( struct cons_pointer arg, - struct stack_frame *frame, - long int *i_accumulator, - long double *d_accumulator, int *is_int ) { - struct cons_pointer result = NIL; - struct cons_space_object cell = pointer2cell( arg ); - - switch ( cell.tag.value ) { - case INTEGERTV: - ( *i_accumulator ) += cell.payload.integer.value; - ( *d_accumulator ) += numeric_value( arg ); - break; - case REALTV: - ( *d_accumulator ) += cell.payload.real.value; - ( *is_int ) &= false; - break; - case EXCEPTIONTV: - result = arg; - break; - default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), frame ); - } - return result; -} - - -/** - * Add an indefinite number of numbers together - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ -struct cons_pointer -lisp_add( struct stack_frame *frame, struct cons_pointer env ) { - struct cons_pointer result = NIL; - long int i_accumulator = 0; - long double d_accumulator = 0; - int is_int = true; - - for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { - result = - add_accumulate( frame->arg[i], frame, &i_accumulator, - &d_accumulator, &is_int ); - } - - struct cons_pointer more = frame->more; - - while ( consp( more ) ) { - result = - add_accumulate( c_car( more ), frame, &i_accumulator, - &d_accumulator, &is_int ); - more = c_cdr( more ); - } - - if ( is_int ) { - result = make_integer( i_accumulator ); - } else { - result = make_real( d_accumulator ); - } - - return result; -} - -/** - * Internal guts of multiply. Dark and mysterious. - */ -struct cons_pointer multiply_accumulate( struct cons_pointer arg, - struct stack_frame *frame, - long int *i_accumulator, - long double *d_accumulator, - int *is_int ) { - struct cons_pointer result = NIL; - struct cons_space_object cell = pointer2cell( arg ); - - switch ( cell.tag.value ) { - case INTEGERTV: - ( *i_accumulator ) *= cell.payload.integer.value; - ( *d_accumulator ) *= numeric_value( arg ); - break; - case REALTV: - ( *d_accumulator ) *= cell.payload.real.value; - ( *is_int ) &= false; - break; - case EXCEPTIONTV: - result = arg; - break; - default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), frame ); - } - return result; -} - -/** - * Multiply an indefinite number of numbers together - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ -struct cons_pointer -lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) { - struct cons_pointer result = NIL; - long int i_accumulator = 1; - long double d_accumulator = 1; - int is_int = true; - - for ( int i = 0; - i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result ); - i++ ) { - result = - multiply_accumulate( frame->arg[i], frame, &i_accumulator, - &d_accumulator, &is_int ); - } - - struct cons_pointer more = frame->more; - - while ( consp( more ) && !exceptionp( result ) ) { - result = - multiply_accumulate( c_car( more ), frame, &i_accumulator, - &d_accumulator, &is_int ); - more = c_cdr( more ); - } - - if ( !exceptionp( result ) ) { - if ( is_int ) { - result = make_integer( i_accumulator ); - } else { - result = make_real( d_accumulator ); - } - } - - return result; -} - -/** - * Subtract one number from another. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ -struct cons_pointer -lisp_subtract( struct stack_frame *frame, struct cons_pointer env ) { - struct cons_pointer result = NIL; - - struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); - struct cons_space_object arg1 = pointer2cell( frame->arg[1] ); - - if ( integerp( frame->arg[0] ) && integerp( frame->arg[1] ) ) { - result = - make_integer( arg0.payload.integer.value - - arg1.payload.integer.value ); - } else if ( realp( frame->arg[0] ) && realp( frame->arg[1] ) ) { - result = - make_real( arg0.payload.real.value - arg1.payload.real.value ); - } else if ( integerp( frame->arg[0] ) && realp( frame->arg[1] ) ) { - result = - make_real( numeric_value( frame->arg[0] ) - - arg1.payload.real.value ); - } else if ( realp( frame->arg[0] ) && integerp( frame->arg[1] ) ) { - result = - make_real( arg0.payload.real.value - - numeric_value( frame->arg[1] ) ); - } else { - /* TODO: throw an exception */ - lisp_throw( c_string_to_lisp_string - ( "Cannot subtract: not a number" ), frame ); - } - - // and if not nilp[frame->arg[2]) we also have an error. - - return result; -} - -/** - * Divide one number by another. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ -struct cons_pointer -lisp_divide( struct stack_frame *frame, struct cons_pointer env ) { - struct cons_pointer result = NIL; - - struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); - struct cons_space_object arg1 = pointer2cell( frame->arg[1] ); - - if ( numberp( frame->arg[1] ) && numeric_value( frame->arg[1] ) == 0 ) { - lisp_throw( c_string_to_lisp_string - ( "Cannot divide: divisor is zero" ), frame ); - } else if ( numberp( frame->arg[0] ) && numberp( frame->arg[1] ) ) { - long int i = ( long int ) numeric_value( frame->arg[0] ) / - numeric_value( frame->arg[1] ); - long double r = ( long double ) numeric_value( frame->arg[0] ) / - numeric_value( frame->arg[1] ); - if ( fabsl( ( long double ) i - r ) < 0.0000000001 ) { - result = make_integer( i ); - } else { - result = make_real( r ); - } - } else { - lisp_throw( c_string_to_lisp_string - ( "Cannot divide: not a number" ), frame ); - } - - return result; -} diff --git a/src/repl.c b/src/repl.c index 40f6300..e0170b6 100644 --- a/src/repl.c +++ b/src/repl.c @@ -13,6 +13,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "debug.h" #include "intern.h" #include "lispops.h" #include "read.h" @@ -31,11 +32,18 @@ * Dummy up a Lisp read call with its own stack frame. */ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { - struct stack_frame *frame = make_empty_frame( NULL, oblist ); - - frame->arg[0] = stream_pointer; - struct cons_pointer result = lisp_read( frame, oblist ); - free_stack_frame( frame ); + struct cons_pointer result = NIL; + debug_print( L"Entered repl_read\n", DEBUG_REPL ); + struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons(stream_pointer, NIL), oblist ); + debug_print( L"repl_read: got stack_frame pointer\n", DEBUG_REPL ); + debug_dump_object( frame_pointer, DEBUG_REPL ); + if ( !nilp( frame_pointer ) ) { + inc_ref( frame_pointer ); + result = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, oblist ); + dec_ref( frame_pointer ); + } + debug_print( L"repl_read: returning\n", DEBUG_REPL ); + debug_dump_object( result, DEBUG_REPL ); return result; } @@ -44,14 +52,13 @@ struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { * Dummy up a Lisp eval call with its own stack frame. */ struct cons_pointer repl_eval( struct cons_pointer input ) { - struct stack_frame *frame = make_empty_frame( NULL, oblist ); + debug_print( L"Entered repl_eval\n", DEBUG_REPL ); + struct cons_pointer result = NIL; - frame->arg[0] = input; - struct cons_pointer result = lisp_eval( frame, oblist ); + result = eval_form( NULL, NIL, input, oblist ); - if ( !exceptionp( result ) ) { - free_stack_frame( frame ); - } + debug_print( L"repl_eval: returning\n", DEBUG_REPL ); + debug_dump_object( result, DEBUG_REPL ); return result; } @@ -61,12 +68,12 @@ struct cons_pointer repl_eval( struct cons_pointer input ) { */ struct cons_pointer repl_print( struct cons_pointer stream_pointer, struct cons_pointer value ) { - struct stack_frame *frame = make_empty_frame( NULL, oblist ); - - frame->arg[0] = value; - frame->arg[1] = NIL /* stream_pointer */ ; - struct cons_pointer result = lisp_print( frame, oblist ); - free_stack_frame( frame ); + debug_print( L"Entered repl_print\n", DEBUG_REPL ); + debug_dump_object( value, DEBUG_REPL ); + struct cons_pointer result = + print( pointer2cell( stream_pointer ).payload.stream.stream, value ); + debug_print( L"repl_print: returning\n", DEBUG_REPL ); + debug_dump_object( result, DEBUG_REPL ); return result; } @@ -81,30 +88,30 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer, void repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, bool show_prompt ) { + debug_print( L"Entered repl\n", DEBUG_REPL ); struct cons_pointer input_stream = make_read_stream( in_stream ); - struct cons_pointer output_stream = make_write_stream( out_stream ); + inc_ref( input_stream ); + struct cons_pointer output_stream = make_write_stream( out_stream ); + inc_ref( output_stream ); while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) { if ( show_prompt ) { fwprintf( out_stream, L"\n:: " ); } struct cons_pointer input = repl_read( input_stream ); + inc_ref( input ); if ( exceptionp( input ) ) { + /* suppress the end-of-stream exception */ + if ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) { + repl_print( output_stream, input ); + } break; } else { - - struct cons_pointer val = repl_eval( input ); - - if ( feof( pointer2cell( input_stream ).payload.stream.stream ) ) { - /* suppress the 'end of stream' exception */ - if ( !exceptionp( val ) ) { - repl_print( output_stream, val ); - } - } else { - repl_print( output_stream, val ); - } + repl_print( output_stream, repl_eval( input ) ); } + dec_ref( input ); } + debug_print( L"Leaving repl\n", DEBUG_REPL ); } diff --git a/src/stack.c b/src/stack.c deleted file mode 100644 index 3554f22..0000000 --- a/src/stack.c +++ /dev/null @@ -1,206 +0,0 @@ -/* - * stack.c - * - * The Lisp evaluation stack. - * - * Stack frames could be implemented in cons space; indeed, the stack - * could simply be an assoc list consed onto the front of the environment. - * But such a stack would be costly to search. The design sketched here, - * with stack frames as special objects, SHOULD be substantially more - * efficient, but does imply we need to generalise the idea of cons pages - * with freelists to a more general 'equal sized object pages', so that - * allocating/freeing stack frames can be more efficient. - * - * Stack frames are not yet a first class object; they have no VECP pointer - * in cons space. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include - -#include "consspaceobject.h" -#include "conspage.h" -#include "lispops.h" -#include "print.h" -#include "stack.h" - -/** - * Make an empty stack frame, and return it. - * @param previous the current top-of-stack; - * @param env the environment in which evaluation happens. - * @return the new frame. - */ -struct stack_frame *make_empty_frame( struct stack_frame *previous, - struct cons_pointer env ) { - struct stack_frame *result = malloc( sizeof( struct stack_frame ) ); - /* - * TODO: later, pop a frame off a free-list of stack frames - */ - - result->previous = previous; - - /* - * clearing the frame with memset would probably be slightly quicker, but - * this is clear. - */ - result->more = NIL; - result->function = NIL; - - for ( int i = 0; i < args_in_frame; i++ ) { - result->arg[i] = NIL; - } - - return result; -} - - -/** - * Allocate a new stack frame with its previous pointer set to this value, - * its arguments set up from these args, evaluated in this env. - * @param previous the current top-of-stack; - * @args the arguments to load into this frame; - * @param env the environment in which evaluation happens. - * @return the new frame. - */ -struct stack_frame *make_stack_frame( struct stack_frame *previous, - struct cons_pointer args, - struct cons_pointer env, - struct cons_pointer *exception ) { - struct stack_frame *result = make_empty_frame( previous, env ); - - for ( int i = 0; i < args_in_frame && consp( args ); i++ ) { - /* iterate down the arg list filling in the arg slots in the - * frame. When there are no more slots, if there are still args, - * stash them on more */ - struct cons_space_object cell = pointer2cell( args ); - - /* - * TODO: if we were running on real massively parallel hardware, - * each arg except the first should be handed off to another - * processor to be evaled in parallel; but see notes here: - * https://github.com/simon-brooke/post-scarcity/wiki/parallelism - */ - struct stack_frame *arg_frame = make_empty_frame( result, env ); - arg_frame->arg[0] = cell.payload.cons.car; - inc_ref( arg_frame->arg[0] ); - - struct cons_pointer val = lisp_eval( arg_frame, env ); - if ( exceptionp( val ) ) { - exception = &val; - break; - } else { - result->arg[i] = val; - } - inc_ref( val ); - - free_stack_frame( arg_frame ); - - args = cell.payload.cons.cdr; - } - if ( consp( args ) ) { - /* if we still have args, eval them and stick the values on `more` */ - struct cons_pointer more = eval_forms( previous, args, env ); - result->more = more; - inc_ref( more ); - } - - dump_frame( stderr, result ); - return result; -} - -/** - * A 'special' frame is exactly like a normal stack frame except that the - * arguments are unevaluated. - * @param previous the previous stack frame; - * @param args a list of the arguments to be stored in this stack frame; - * @param env the execution environment; - * @return a new special frame. - */ -struct stack_frame *make_special_frame( struct stack_frame *previous, - struct cons_pointer args, - struct cons_pointer env ) { - struct stack_frame *result = make_empty_frame( previous, env ); - - for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) { - /* iterate down the arg list filling in the arg slots in the - * frame. When there are no more slots, if there are still args, - * stash them on more */ - struct cons_space_object cell = pointer2cell( args ); - - result->arg[i] = cell.payload.cons.car; - inc_ref( result->arg[i] ); - - args = cell.payload.cons.cdr; - } - if ( consp( args ) ) { - result->more = args; - inc_ref( args ); - } - - return result; -} - -/** - * Free this stack frame. - */ -void free_stack_frame( struct stack_frame *frame ) { - /* - * TODO: later, push it back on the stack-frame freelist - */ - for ( int i = 0; i < args_in_frame; i++ ) { - dec_ref( frame->arg[i] ); - } - if ( !nilp( frame->more ) ) { - dec_ref( frame->more ); - } - - free( frame ); -} - - -/** - * Dump a stackframe to this stream for debugging - * @param output the stream - * @param frame the frame - */ -void dump_frame( FILE * output, struct stack_frame *frame ) { - fputws( L"Dumping stack frame\n", output ); - for ( int arg = 0; arg < args_in_frame; arg++ ) { - struct cons_space_object cell = pointer2cell( frame->arg[arg] ); - - fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg, - cell.tag.bytes[0], - cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3], - cell.count ); - - print( output, frame->arg[arg] ); - fputws( L"\n", output ); - } - fputws( L"More: \t", output ); - print( output, frame->more ); - fputws( L"\n", output ); -} - - -/** - * Fetch a pointer to the value of the local variable at this index. - */ -struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int index ) { - struct cons_pointer result = NIL; - - if ( index < args_in_frame ) { - result = frame->arg[index]; - } else { - struct cons_pointer p = frame->more; - - for ( int i = args_in_frame; i < index; i++ ) { - p = pointer2cell( p ).payload.cons.cdr; - } - - result = pointer2cell( p ).payload.cons.car; - } - - return result; -} diff --git a/src/version.h b/src/version.h index eb9d34e..96fb98e 100644 --- a/src/version.h +++ b/src/version.h @@ -8,4 +8,4 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#define VERSION "0.0.3" +#define VERSION "0.0.4" diff --git a/unit-tests/add.sh b/unit-tests/add.sh index 7bb29c7..4516808 100644 --- a/unit-tests/add.sh +++ b/unit-tests/add.sh @@ -23,3 +23,57 @@ else exit 1 fi +expected='1/4' +actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +# (+ integer ratio) should be ratio +expected='25/4' +actual=`echo "(+ 6 1/4)" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +# (+ ratio integer) should be ratio +expected='25/4' +actual=`echo "(+ 1/4 6)" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +# (+ real ratio) should be real +# for this test, trailing zeros can be ignored +expected='6.25' +actual=`echo "(+ 6.000000001 1/4)" |\ + target/psse 2> /dev/null |\ + sed 's/0*$//' |\ + head -2 |\ + tail -1` + +outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc` + +if [ "${outcome}" = "1" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + diff --git a/unit-tests/nlambda.sh b/unit-tests/nlambda.sh new file mode 100644 index 0000000..f267527 --- /dev/null +++ b/unit-tests/nlambda.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +expected='a' +actual=`echo "((nlambda (x) x) a)" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/ratio-addition.sh b/unit-tests/ratio-addition.sh new file mode 100644 index 0000000..f57d0b0 --- /dev/null +++ b/unit-tests/ratio-addition.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +expected='1/4' +actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/reverse.sh b/unit-tests/reverse.sh new file mode 100644 index 0000000..4e3f8f6 --- /dev/null +++ b/unit-tests/reverse.sh @@ -0,0 +1,36 @@ +#!/bin/bash + +expected='"god yzal eht revo depmuj xof nworb kciuq ehT"' +actual=`echo '(reverse "The quick brown fox jumped over the lazy dog")' | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='(1024 512 256 128 64 32 16 8 4 2)' +actual=`echo "(reverse '(2 4 8 16 32 64 128 256 512 1024))" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='esrever' +actual=`echo "(reverse 'reverse)" | target/psse 2> /dev/null | head -2 | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + diff --git a/unit-tests/string-allocation.sh b/unit-tests/string-allocation.sh index 7fe78c4..6f55143 100644 --- a/unit-tests/string-allocation.sh +++ b/unit-tests/string-allocation.sh @@ -1,17 +1,15 @@ #!/bin/bash -log=log.$$ value='"Fred"' -expected="String cell: character 'F' (70)" -echo ${value} | target/psse -d > ${log} 2>/dev/null -grep "${expected}" ${log} > /dev/null +expected="String cell: character 'F'" +# set! protects "Fred" from the garbage collector. +actual=`echo "(set! x ${value})" | target/psse -d 2>&1 | grep "$expected" | sed 's/ *\(.*\) next.*$/\1/'` if [ $? -eq 0 ] then echo "OK" - rm ${log} exit 0 else - echo "Expected '${expected}', not found in ${log}" + echo "Fail: expected '${expected}', got '${actual}'" exit 1 fi diff --git a/utils_src/debugflags/debugflags b/utils_src/debugflags/debugflags new file mode 100755 index 0000000..49b2a08 Binary files /dev/null and b/utils_src/debugflags/debugflags differ diff --git a/utils_src/debugflags/debugflags.c b/utils_src/debugflags/debugflags.c new file mode 100644 index 0000000..a9850d1 --- /dev/null +++ b/utils_src/debugflags/debugflags.c @@ -0,0 +1,43 @@ +#include +#include +#include +#include +#include + + +#define DEBUG_ALLOC 1 +#define DEBUG_STACK 2 +#define DEBUG_ARITH 4 +#define DEBUG_EVAL 8 +#define DEBUG_LAMBDA 16 +#define DEBUG_BOOTSTRAP 32 +#define DEBUG_IO 64 +#define DEBUG_REPL 128 + +int check_level( int v, int level, char * name) { + int result = 0; + if (v & level) { + printf("\t\t%s (%d) matches;\n", name, level); + result = 1; + } + + return result; +} + +int main( int argc, char *argv[] ) { + + for (int i = 1; i < argc; i++) { + int v = atoi(argv[i]); + + printf("Level %d:\n", v); + int matches = check_level(v, DEBUG_ALLOC, "DEBUG_ALLOC") + + check_level(v, DEBUG_STACK, "DEBUG_STACK") + + check_level(v, DEBUG_ARITH, "DEBUG_ARITH") + + check_level(v, DEBUG_EVAL, "DEBUG_EVAL") + + check_level(v, DEBUG_LAMBDA, "DEBUG_LAMBDA") + + check_level(v, DEBUG_BOOTSTRAP, "DEBUG_BOOTSTRAP") + + check_level(v, DEBUG_IO, "DEBUG_IO") + + check_level(v, DEBUG_REPL, "DEBUG_REPL"); + printf("\t%d matches\n", matches); + } +} diff --git a/utils_src/readprintwc/readprintwc.c b/utils_src/readprintwc/readprintwc.c new file mode 100644 index 0000000..e221c9c --- /dev/null +++ b/utils_src/readprintwc/readprintwc.c @@ -0,0 +1,17 @@ +#include +#include +#include +#include + +int main( int argc, char *argv[] ) { + fwide( stdin, 1 ); + fwide( stdout, 1 ); + + for (wchar_t c = fgetwc( stdin ); !feof( stdin); c = fgetwc( stdin )) { + if (c != '\n') { + fwprintf( stdout, L"Read character %d, %C\t", (int)c, c); + fputwc( c, stdout); + fputws(L"\n", stdout); + } + } +} diff --git a/utils_src/tagvalcalc/tagvalcalc.c b/utils_src/tagvalcalc/tagvalcalc.c new file mode 100644 index 0000000..67828bd --- /dev/null +++ b/utils_src/tagvalcalc/tagvalcalc.c @@ -0,0 +1,26 @@ +#include +#include +#include +#include + +#define TAGLENGTH 4 + +struct dummy { + union { + char bytes[TAGLENGTH]; /* the tag (type) of this cell, + * considered as bytes */ + uint32_t value; /* the tag considered as a number */ + } tag; +}; + +int main( int argc, char *argv[] ) { + struct dummy *b = malloc( sizeof( struct dummy)); + struct dummy buffer = *b; + + for (int i = 1; i < argc; i++) { + + strncpy( &buffer.tag.bytes[0], argv[i], TAGLENGTH ); + + printf( "%4.4s:\t%d\n", argv[i], buffer.tag.value); + } +} diff --git a/utils_src/tagvalcalc/tvc b/utils_src/tagvalcalc/tvc new file mode 100755 index 0000000..a639364 Binary files /dev/null and b/utils_src/tagvalcalc/tvc differ