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 98a6bd3..c368d50 100644 --- a/Makefile +++ b/Makefile @@ -23,7 +23,7 @@ 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/src/arith/integer.c b/src/arith/integer.c index 60ce8c3..5239746 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -13,6 +13,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "debug.h" /** * return the numeric value of this cell, as a C primitive double, not @@ -40,9 +41,7 @@ struct cons_pointer make_integer( int64_t value ) { struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; -#ifdef DEBUG - dump_object( stderr, result ); -#endif + debug_dump_object( result, DEBUG_ARITH ); return result; } diff --git a/src/arith/peano.c b/src/arith/peano.c index 423bd51..9f5e0fb 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -8,14 +8,15 @@ */ #include +#include #include #include #include #include -#include #include "consspaceobject.h" #include "conspage.h" +#include "debug.h" #include "equal.h" #include "integer.h" #include "intern.h" @@ -28,7 +29,9 @@ 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 arg1, +struct cons_pointer add_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer arg1, struct cons_pointer arg2 ); @@ -84,9 +87,9 @@ long double to_long_double( struct cons_pointer arg ) { break; } - fputws( L"to_long_double( ", stderr ); - print( stderr, arg ); - fwprintf( stderr, L") => %lf\n", result ); + debug_print( L"to_long_double( ", DEBUG_ARITH ); + debug_print_object( arg, DEBUG_ARITH ); + debug_printf( DEBUG_ARITH, L") => %lf\n", result ); return result; } @@ -119,19 +122,19 @@ int64_t to_long_int( struct cons_pointer arg ) { * 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 arg1, +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 ); -#ifdef DEBUG - fputws( L"add_2( arg1 = ", stderr ); - print( stderr, arg1 ); - fputws( L"; arg2 = ", stderr ); - print( stderr, arg2 ); - fputws( L")\n", stderr ); -#endif + 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; @@ -153,7 +156,8 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, cell2.payload.integer.value ); break; case RATIOTV: - result = add_integer_ratio( frame, arg1, arg2 ); + result = + add_integer_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = @@ -161,9 +165,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, to_long_double( arg2 ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot add: not a number" ), - frame ); + result = throw_exception( c_string_to_lisp_string + ( L"Cannot add: not a number" ), + frame_pointer ); break; } break; @@ -173,10 +177,11 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, result = arg2; break; case INTEGERTV: - result = add_integer_ratio( frame, arg2, arg1 ); + result = + add_integer_ratio( frame_pointer, arg2, arg1 ); break; case RATIOTV: - result = add_ratio_ratio( frame, arg1, arg2 ); + result = add_ratio_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = @@ -184,9 +189,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, to_long_double( arg2 ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot add: not a number" ), - frame ); + result = throw_exception( c_string_to_lisp_string + ( L"Cannot add: not a number" ), + frame_pointer ); break; } break; @@ -197,16 +202,15 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, break; default: result = exceptionp( arg2 ) ? arg2 : - lisp_throw( c_string_to_lisp_string - ( "Cannot add: not a number" ), frame ); + throw_exception( c_string_to_lisp_string + ( L"Cannot add: not a number" ), + frame_pointer ); } } -#ifdef DEBUG - fputws( L"}; => ", stderr ); - print( stderr, arg2 ); - fputws( L"\n", stderr ); -#endif + debug_print( L"}; => ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); return result; } @@ -218,7 +222,7 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, * @return a pointer to an integer or real. */ struct cons_pointer lisp_add( struct stack_frame - *frame, struct + *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = make_integer( 0 ); struct cons_pointer tmp; @@ -227,7 +231,7 @@ struct cons_pointer lisp_add( struct stack_frame i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) { tmp = result; - result = add_2( frame, result, frame->arg[i] ); + result = add_2( frame, frame_pointer, result, frame->arg[i] ); if ( !eq( tmp, result ) ) { dec_ref( tmp ); } @@ -236,7 +240,7 @@ struct cons_pointer lisp_add( struct stack_frame struct cons_pointer more = frame->more; while ( consp( more ) && !exceptionp( result ) ) { tmp = result; - result = add_2( frame, result, c_car( more ) ); + result = add_2( frame, frame_pointer, result, c_car( more ) ); if ( !eq( tmp, result ) ) { dec_ref( tmp ); } @@ -253,19 +257,18 @@ struct cons_pointer lisp_add( struct stack_frame * 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 ); -#ifdef DEBUG - fputws( L"multiply_2( arg1 = ", stderr ); - print( stderr, arg1 ); - fputws( L"; arg2 = ", stderr ); - print( stderr, arg2 ); - fputws( L")\n", stderr ); -#endif + 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; @@ -286,7 +289,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame, cell2.payload.integer.value ); break; case RATIOTV: - result = multiply_integer_ratio( frame, arg1, arg2 ); + result = + multiply_integer_ratio( frame_pointer, arg1, + arg2 ); break; case REALTV: result = @@ -294,9 +299,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), - frame ); + result = throw_exception( c_string_to_lisp_string + ( L"Cannot multiply: not a number" ), + frame_pointer ); break; } break; @@ -306,10 +311,13 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = multiply_integer_ratio( frame, arg2, arg1 ); + result = + multiply_integer_ratio( frame_pointer, arg2, + arg1 ); break; case RATIOTV: - result = multiply_ratio_ratio( frame, arg1, arg2 ); + result = + multiply_ratio_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = @@ -317,9 +325,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), - frame ); + result = throw_exception( c_string_to_lisp_string + ( L"Cannot multiply: not a number" ), + frame_pointer ); } break; case REALTV: @@ -328,18 +336,16 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), - frame ); + result = throw_exception( c_string_to_lisp_string + ( L"Cannot multiply: not a number" ), + frame_pointer ); break; } } -#ifdef DEBUG - fputws( L" => ", stderr ); - print( stderr, arg2 ); - fputws( L"\n", stderr ); -#endif + debug_print( L" => ", DEBUG_ARITH ); + debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); return result; } @@ -353,7 +359,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, */ struct cons_pointer lisp_multiply( struct stack_frame - *frame, struct + *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = make_integer( 1 ); struct cons_pointer tmp; @@ -361,7 +367,7 @@ struct cons_pointer lisp_multiply( struct for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) { tmp = result; - result = multiply_2( frame, result, frame->arg[i] ); + result = multiply_2( frame, frame_pointer, result, frame->arg[i] ); if ( !eq( tmp, result ) ) { dec_ref( tmp ); @@ -372,7 +378,7 @@ struct cons_pointer lisp_multiply( struct while ( consp( more ) && !exceptionp( result ) ) { tmp = result; - result = multiply_2( frame, result, c_car( more ) ); + result = multiply_2( frame, frame_pointer, result, c_car( more ) ); if ( !eq( tmp, result ) ) { dec_ref( tmp ); @@ -388,7 +394,7 @@ struct cons_pointer lisp_multiply( struct * return a cons_pointer indicating a number which is the * inverse of the number indicated by `arg`. */ -struct cons_pointer inverse( struct stack_frame *frame, +struct cons_pointer inverse( struct cons_pointer frame, struct cons_pointer arg ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); @@ -406,8 +412,8 @@ struct cons_pointer inverse( struct stack_frame *frame, case RATIOTV: result = make_ratio( frame, make_integer( 0 - - to_long_int( cell.payload.ratio. - dividend ) ), + to_long_int( cell.payload. + ratio.dividend ) ), cell.payload.ratio.divisor ); break; case REALTV: @@ -430,7 +436,7 @@ struct cons_pointer inverse( struct stack_frame *frame, */ struct cons_pointer lisp_subtract( struct stack_frame - *frame, struct + *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; struct cons_space_object cell0 = pointer2cell( frame->arg[0] ); @@ -451,10 +457,12 @@ struct cons_pointer lisp_subtract( struct break; case RATIOTV:{ struct cons_pointer tmp = - make_ratio( frame, frame->arg[0], + make_ratio( frame_pointer, frame->arg[0], make_integer( 1 ) ); + inc_ref( tmp ); result = - subtract_ratio_ratio( frame, tmp, frame->arg[1] ); + subtract_ratio_ratio( frame_pointer, tmp, + frame->arg[1] ); dec_ref( tmp ); } break; @@ -464,9 +472,9 @@ struct cons_pointer lisp_subtract( struct to_long_double( frame->arg[1] ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), - frame ); + result = throw_exception( c_string_to_lisp_string + ( L"Cannot subtract: not a number" ), + frame_pointer ); break; } break; @@ -477,16 +485,18 @@ struct cons_pointer lisp_subtract( struct break; case INTEGERTV:{ struct cons_pointer tmp = - make_ratio( frame, frame->arg[1], + make_ratio( frame_pointer, frame->arg[1], make_integer( 1 ) ); + inc_ref( tmp ); result = - subtract_ratio_ratio( frame, frame->arg[0], tmp ); + subtract_ratio_ratio( frame_pointer, frame->arg[0], + tmp ); dec_ref( tmp ); } break; case RATIOTV: result = - subtract_ratio_ratio( frame, frame->arg[0], + subtract_ratio_ratio( frame_pointer, frame->arg[0], frame->arg[1] ); break; case REALTV: @@ -495,9 +505,9 @@ struct cons_pointer lisp_subtract( struct to_long_double( frame->arg[1] ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), - frame ); + result = throw_exception( c_string_to_lisp_string + ( L"Cannot subtract: not a number" ), + frame_pointer ); break; } break; @@ -507,8 +517,9 @@ struct cons_pointer lisp_subtract( struct to_long_double( frame->arg[1] ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot multiply: not a number" ), frame ); + result = throw_exception( c_string_to_lisp_string + ( L"Cannot subtract: not a number" ), + frame_pointer ); break; } @@ -525,7 +536,7 @@ struct cons_pointer lisp_subtract( struct */ struct cons_pointer lisp_divide( struct stack_frame - *frame, struct + *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; struct cons_space_object arg0 = pointer2cell( frame->arg[0] ); @@ -542,8 +553,11 @@ struct cons_pointer lisp_divide( struct break; case INTEGERTV:{ struct cons_pointer unsimplified = - make_ratio( frame, frame->arg[0], frame->arg[1] ); - result = simplify_ratio( frame, 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 ); } @@ -552,9 +566,10 @@ struct cons_pointer lisp_divide( struct case RATIOTV:{ struct cons_pointer one = make_integer( 1 ); struct cons_pointer ratio = - make_ratio( frame, frame->arg[0], one ); + make_ratio( frame_pointer, frame->arg[0], one ); result = - divide_ratio_ratio( frame, ratio, frame->arg[1] ); + divide_ratio_ratio( frame_pointer, ratio, + frame->arg[1] ); dec_ref( ratio ); } break; @@ -564,9 +579,9 @@ struct cons_pointer lisp_divide( struct to_long_double( frame->arg[1] ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot divide: not a number" ), - frame ); + result = throw_exception( c_string_to_lisp_string + ( L"Cannot divide: not a number" ), + frame_pointer ); break; } break; @@ -577,16 +592,20 @@ struct cons_pointer lisp_divide( struct break; case INTEGERTV:{ struct cons_pointer one = make_integer( 1 ); + inc_ref( one ); struct cons_pointer ratio = - make_ratio( frame, frame->arg[1], one ); + make_ratio( frame_pointer, frame->arg[1], one ); + inc_ref( ratio ); result = - divide_ratio_ratio( frame, frame->arg[0], ratio ); + divide_ratio_ratio( frame_pointer, frame->arg[0], + ratio ); dec_ref( ratio ); + dec_ref( one ); } break; case RATIOTV: result = - divide_ratio_ratio( frame, frame->arg[0], + divide_ratio_ratio( frame_pointer, frame->arg[0], frame->arg[1] ); break; case REALTV: @@ -595,9 +614,9 @@ struct cons_pointer lisp_divide( struct to_long_double( frame->arg[1] ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot divide: not a number" ), - frame ); + result = throw_exception( c_string_to_lisp_string + ( L"Cannot divide: not a number" ), + frame_pointer ); break; } break; @@ -607,8 +626,9 @@ struct cons_pointer lisp_divide( struct to_long_double( frame->arg[1] ) ); break; default: - result = lisp_throw( c_string_to_lisp_string - ( "Cannot divide: not a number" ), frame ); + result = throw_exception( c_string_to_lisp_string + ( L"Cannot divide: not a number" ), + frame_pointer ); break; } diff --git a/src/arith/peano.h b/src/arith/peano.h index 79735c0..f1c21b4 100644 --- a/src/arith/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 index 8a5eec7..ca83335 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -13,6 +13,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "debug.h" #include "equal.h" #include "integer.h" #include "lispops.h" @@ -24,7 +25,7 @@ * declared in peano.c, can't include piano.h here because * circularity. TODO: refactor. */ -struct cons_pointer inverse( struct stack_frame *frame, +struct cons_pointer inverse( struct cons_pointer frame_pointer, struct cons_pointer arg ); /** @@ -54,31 +55,31 @@ int64_t least_common_multiple( int64_t m, int64_t n ) { * be in a simplified representation. If `arg` isn't a ratio, * will throw exception. */ -struct cons_pointer simplify_ratio( struct stack_frame *frame, +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 ); + 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, make_integer( ddrv / gcd ), + make_ratio( frame_pointer, make_integer( ddrv / gcd ), make_integer( drrv / gcd ) ); } } } else { result = - lisp_throw( make_cons( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to simplify_ratio" ), - arg ), frame ); + throw_exception( make_cons( c_string_to_lisp_string + ( L"Shouldn't happen: bad arg to simplify_ratio" ), + arg ), frame_pointer ); } return result; @@ -91,18 +92,16 @@ struct cons_pointer simplify_ratio( struct stack_frame *frame, * 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 stack_frame *frame, +struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer r, result; -#ifdef DEBUG - fputws( L"add_ratio_ratio( arg1 = ", stderr ); - print( stderr, arg1 ); - fputws( L"; arg2 = ", stderr ); - print( stderr, arg2 ); - fputws( L")\n", stderr ); -#endif + 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 ); @@ -118,12 +117,10 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, lcm = least_common_multiple( dr1v, dr2v ), m1 = lcm / dr1v, m2 = lcm / dr2v; -#ifdef DEBUG - fwprintf( stderr, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); -#endif + debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); if ( dr1v == dr2v ) { - r = make_ratio( frame, + r = make_ratio( frame_pointer, make_integer( dd1v + dd2v ), cell1.payload.ratio.divisor ); } else { @@ -131,10 +128,10 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, dr1vm = make_integer( dr1v * m1 ), dd2vm = make_integer( dd2v * m2 ), dr2vm = make_integer( dr2v * m2 ), - r1 = make_ratio( frame, dd1vm, dr1vm ), - r2 = make_ratio( frame, dd2vm, dr2vm ); + r1 = make_ratio( frame_pointer, dd1vm, dr1vm ), + r2 = make_ratio( frame_pointer, dd2vm, dr2vm ); - r = add_ratio_ratio( frame, r1, r2 ); + 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 @@ -143,24 +140,22 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, dec_ref( r2 ); } - result = simplify_ratio( frame, r ); + result = simplify_ratio( frame_pointer, r ); if ( !eq( r, result ) ) { dec_ref( r ); } } else { result = - lisp_throw( make_cons( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to add_ratio_ratio" ), - make_cons( arg1, - make_cons( arg2, NIL ) ) ), - frame ); + 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 ); } -#ifdef DEBUG - fputws( L" => ", stderr ); - print( stderr, result ); - fputws( L"\n", stderr ); -#endif + debug_print( L" => ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); return result; } @@ -171,26 +166,27 @@ struct cons_pointer add_ratio_ratio( struct stack_frame *frame, * 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 stack_frame *frame, +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, intarg, one ); + ratio = make_ratio( frame_pointer, intarg, one ); - result = add_ratio_ratio( frame, ratio, ratarg ); + result = add_ratio_ratio( frame_pointer, ratio, ratarg ); dec_ref( one ); dec_ref( ratio ); } else { result = - lisp_throw( make_cons( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to add_integer_ratio" ), - make_cons( intarg, - make_cons( ratarg, NIL ) ) ), - frame ); + 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; @@ -201,15 +197,16 @@ struct cons_pointer add_integer_ratio( struct stack_frame *frame, * 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 stack_frame *frame, +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, - pointer2cell( arg2 ).payload.ratio. - divisor, - pointer2cell( arg2 ).payload.ratio. - dividend ), result = - multiply_ratio_ratio( frame, arg1, i ); + 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 ); @@ -221,20 +218,17 @@ struct cons_pointer divide_ratio_ratio( struct stack_frame *frame, * 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 - stack_frame - *frame, struct +struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer result; -#ifdef DEBUG - fputws( L"multiply_ratio_ratio( arg1 = ", stderr ); - print( stderr, arg1 ); - fputws( L"; arg2 = ", stderr ); - print( stderr, arg2 ); - fputws( L")\n", stderr ); -#endif + 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 ); @@ -249,18 +243,18 @@ struct cons_pointer multiply_ratio_ratio( struct ddrv = dd1v * dd2v, drrv = dr1v * dr2v; struct cons_pointer unsimplified = - make_ratio( frame, make_integer( ddrv ), + make_ratio( frame_pointer, make_integer( ddrv ), make_integer( drrv ) ); - result = simplify_ratio( frame, unsimplified ); + result = simplify_ratio( frame_pointer, unsimplified ); if ( !eq( unsimplified, result ) ) { dec_ref( unsimplified ); } } else { result = - lisp_throw( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to multiply_ratio_ratio" ), - frame ); + throw_exception( c_string_to_lisp_string + ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ), + frame_pointer ); } return result; @@ -271,23 +265,23 @@ struct cons_pointer multiply_ratio_ratio( struct * 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 stack_frame *frame, +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, intarg, one ); - result = multiply_ratio_ratio( frame, ratio, ratarg ); + ratio = make_ratio( frame_pointer, intarg, one ); + result = multiply_ratio_ratio( frame_pointer, ratio, ratarg ); dec_ref( one ); dec_ref( ratio ); } else { result = - lisp_throw( c_string_to_lisp_string - ( "Shouldn't happen: bad arg to multiply_integer_ratio" ), - frame ); + throw_exception( c_string_to_lisp_string + ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ), + frame_pointer ); } return result; @@ -299,11 +293,11 @@ struct cons_pointer multiply_integer_ratio( struct stack_frame *frame, * 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 stack_frame *frame, +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, arg2 ), - result = add_ratio_ratio( frame, arg1, i ); + struct cons_pointer i = inverse( frame_pointer, arg2 ), + result = add_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); @@ -315,7 +309,7 @@ struct cons_pointer subtract_ratio_ratio( struct stack_frame *frame, * 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 stack_frame *frame, +struct cons_pointer make_ratio( struct cons_pointer frame_pointer, struct cons_pointer dividend, struct cons_pointer divisor ) { struct cons_pointer result; @@ -328,13 +322,12 @@ struct cons_pointer make_ratio( struct stack_frame *frame, cell->payload.ratio.divisor = divisor; } else { result = - lisp_throw( c_string_to_lisp_string - ( "Dividend and divisor of a ratio must be integers" ), - frame ); + throw_exception( c_string_to_lisp_string + ( L"Dividend and divisor of a ratio must be integers" ), + frame_pointer ); } -#ifdef DEBUG - dump_object( stderr, result ); -#endif + debug_dump_object( result, DEBUG_ARITH ); + return result; } diff --git a/src/arith/ratio.h b/src/arith/ratio.h index c4e5548..5a3b0d6 100644 --- a/src/arith/ratio.h +++ b/src/arith/ratio.h @@ -11,36 +11,34 @@ #ifndef __ratio_h #define __ratio_h -struct cons_pointer simplify_ratio( struct stack_frame *frame, +struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg ); -struct cons_pointer add_ratio_ratio( struct stack_frame *frame, +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 stack_frame *frame, +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 stack_frame *frame, +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 - stack_frame - *frame, struct +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 stack_frame *frame, +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 stack_frame *frame, +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 stack_frame *frame, +struct cons_pointer make_ratio( struct cons_pointer frame_pointer, struct cons_pointer dividend, struct cons_pointer divisor ); diff --git a/src/arith/real.c b/src/arith/real.c index a499b6a..84ba899 100644 --- a/src/arith/real.c +++ b/src/arith/real.c @@ -9,6 +9,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "debug.h" #include "read.h" /** @@ -22,9 +23,7 @@ struct cons_pointer make_real( long double value ) { struct cons_space_object *cell = &pointer2cell( result ); cell->payload.real.value = value; -#ifdef DEBUG - dump_object( stderr, result ); -#endif + debug_dump_object( result, DEBUG_ARITH ); return result; } 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 9716365..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,53 +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( "reverse", &lisp_reverse ); - 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( "λ", &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/memory/conspage.c b/src/memory/conspage.c index 13d8373..cf87028 100644 --- a/src/memory/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,10 +129,8 @@ void dump_pages( FILE * output ) { void free_cell( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); -#ifdef DEBUG - fwprintf( stderr, L"Freeing cell " ); - dump_object( stderr, pointer ); -#endif + 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 @@ -164,11 +164,9 @@ void free_cell( struct cons_pointer pointer ) { case VECTORPOINTTV: /* for vector space pointers, free the actual vector-space * object. Dangerous! */ -#ifdef DEBUG - fwprintf( stderr, L"About to free vector-space object at %ld\n", + debug_printf( DEBUG_ALLOC, L"About to free vector-space object at %ld\n", cell->payload.vectorp.address ); -#endif - free( ( void * ) cell->payload.vectorp.address ); + //free( ( void * ) cell->payload.vectorp.address ); break; } @@ -180,12 +178,12 @@ void free_cell( struct cons_pointer pointer ) { cell->payload.free.cdr = freelist; freelist = pointer; } else { - fwprintf( stderr, + 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, + debug_printf( DEBUG_ALLOC, L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n", pointer.page, pointer.offset ); } @@ -217,13 +215,11 @@ struct cons_pointer allocate_cell( char *tag ) { 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!" ); } } @@ -242,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/memory/conspage.h b/src/memory/conspage.h index 7b8b930..bc1361e 100644 --- a/src/memory/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/memory/consspaceobject.c b/src/memory/consspaceobject.c index 39f464a..f5cc8b8 100644 --- a/src/memory/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" @@ -63,98 +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 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" ); - 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. @@ -178,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; } @@ -200,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 ); @@ -265,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 ); } @@ -298,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 ); @@ -335,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/memory/consspaceobject.h b/src/memory/consspaceobject.h index 43bdfe0..523fdaa 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -133,7 +133,7 @@ * A pointer to an object in vector space. */ #define VECTORPOINTTAG "VECP" -#define VECTORPOINTTV 0 +#define VECTORPOINTTV 1346585942 /** * An open write stream. */ @@ -263,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; }; /* @@ -278,13 +279,14 @@ 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; }; /** @@ -311,7 +313,7 @@ struct cons_payload { */ struct exception_payload { struct cons_pointer message; - struct stack_frame *frame; + struct cons_pointer frame; }; /** @@ -326,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 ); }; @@ -379,13 +382,11 @@ struct real_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 ); }; @@ -421,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) */ }; /** @@ -514,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. @@ -535,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 ) ); /** @@ -550,20 +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 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 stack_frame *frame, - struct cons_pointer dividend, - struct cons_pointer divisor ); - /** * 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 ) ); /** @@ -595,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 index 1bb8b1b..f91d896 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -11,9 +11,6 @@ * 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. */ @@ -22,39 +19,88 @@ #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; + } +} + /** - * 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. + * get the actual stackframe object from this `pointer`, or NULL if + * `pointer` is not a stackframe pointer. */ -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 - */ +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; - 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++ ) { - set_reg( result, i, NIL ); + 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, @@ -62,49 +108,62 @@ struct stack_frame *make_empty_frame( struct stack_frame *previous, * @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. + * @return the new frame, or an exception if one occurred while building it. */ -struct stack_frame *make_stack_frame( struct stack_frame *previous, +struct cons_pointer make_stack_frame( struct cons_pointer previous, struct cons_pointer args, - struct cons_pointer env, - struct cons_pointer *exception ) { - struct stack_frame *result = make_empty_frame( previous, env ); + struct cons_pointer env ) { + debug_print( L"Entering make_stack_frame\n", DEBUG_STACK ); + struct cons_pointer result = make_empty_frame( previous ); - 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 ); + 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 ); - /* - * 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 ); - set_reg( arg_frame, 0, cell.payload.cons.car ); + 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 ); + } - struct cons_pointer val = lisp_eval( arg_frame, env ); - if ( exceptionp( val ) ) { - exception = &val; - break; - } else { - set_reg( result, i, 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 ); } + debug_print( L"make_stack_frame: returning\n", DEBUG_STACK ); + debug_dump_object( result, DEBUG_STACK ); - dump_frame( stderr, result ); return result; } @@ -116,25 +175,40 @@ struct stack_frame *make_stack_frame( struct stack_frame *previous, * @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 ) { - struct stack_frame *result = make_empty_frame( previous, env ); + debug_print( L"Entering make_special_frame\n", DEBUG_STACK ); - 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 ); + struct cons_pointer result = make_empty_frame( previous ); - set_reg( result, i, cell.payload.cons.car ); + 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 ); - args = cell.payload.cons.cdr; - } - if ( consp( args ) ) { - result->more = args; - inc_ref( args ); + 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; } @@ -160,26 +234,47 @@ void free_stack_frame( struct stack_frame *frame ) { /** * Dump a stackframe to this stream for debugging * @param output the stream - * @param frame the frame + * @param frame_pointer the pointer to 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] ); +void dump_frame( FILE * output, struct cons_pointer frame_pointer ) { + struct stack_frame *frame = get_stack_frame( frame_pointer ); - 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 ); + 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] ); - print( output, 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 ); + } } - 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. diff --git a/src/memory/stack.h b/src/memory/stack.h index d708b39..79cd1e2 100644 --- a/src/memory/stack.h +++ b/src/memory/stack.h @@ -24,46 +24,42 @@ #ifndef __stack_h #define __stack_h +/** + * macros for the tag of a stack frame. + */ +#define STACKFRAMETAG "STAK" +#define STACKFRAMETV 1262572627 + +/** + * is this vector-space object a stack 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) +//#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); -/** - * 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 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 ); -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 ); -/** - * 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 ); +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 index 4b18b96..c30f120 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -8,6 +8,7 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include #include #include @@ -20,6 +21,7 @@ #include "conspage.h" #include "consspaceobject.h" +#include "debug.h" #include "vectorspace.h" @@ -29,12 +31,18 @@ * 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( char *tag, uint64_t address ) { +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 ); + 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 ); - strncpy( &cell.payload.vectorp.tag.bytes[0], tag, 4 ); - cell.payload.vectorp.address = address; + debug_dump_object( pointer, DEBUG_ALLOC ); return pointer; } @@ -44,26 +52,46 @@ struct cons_pointer make_vec_pointer( char *tag, uint64_t address ) { * 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, int64_t payload_size ) { +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; - struct vector_space_header *vso = malloc( total_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 ) { - strncpy( &vso->tag.bytes[0], tag, TAGLENGTH ); - vso->vecp = make_vec_pointer( tag, ( uint64_t ) vso ); - vso->size = payload_size; + 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 - fwprintf( stderr, - L"Allocated vector-space object of type %s, total size %ld, payload size %ld\n", - tag, total_size, payload_size ); + 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 - - result = vso->vecp; } +#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 index 07a0b91..1438d37 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -34,20 +34,16 @@ #define NAMESPACETAG "NMSP" #define NAMESPACETV 0 -/* - * a stack frame. - */ -#define STACKFRAMETAG "STAK" -#define STACKFRAMETV /* * a vector of cons pointers. */ #define VECTORTAG "VECT" #define VECTORTV 0 -#define pointer_to_vso(pointer)(vectorpointp(pointer)? pointer2cell(pointer).payload.vectorp.address : 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, int64_t payload_size ); +struct cons_pointer make_vso( char *tag, uint64_t payload_size ); struct vector_space_header { union { @@ -62,8 +58,10 @@ struct vector_space_header { 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 */ - char mark; /* mark bit for marking/sweeping the - * heap (not in this version) */ +}; + +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 diff --git a/src/ops/equal.c b/src/ops/equal.c index ebb085e..0f0597c 100644 --- a/src/ops/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/ops/intern.c b/src/ops/intern.c index 100589a..27c745d 100644 --- a/src/ops/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/ops/lispops.c b/src/ops/lispops.c index 9b12faa..82746e0 100644 --- a/src/ops/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,22 +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 ); + 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 ); - result = lisp_eval( next, env ); + 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; @@ -107,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; } /** @@ -120,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; } @@ -139,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; } @@ -153,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 ) ); } @@ -164,18 +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 ) { -#ifdef DEBUG - fputws( L"\n\tBinding ", stderr ); - print( stderr, name ); - fputws( L" to ", stderr ); - print( stderr, val ); - fputws( L"\"\n", stderr ); -#endif + 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,19 +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 ); - set_reg( fn_frame, 0, c_car( 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] ); @@ -263,84 +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 ); -#ifdef DEBUG - fputws( L"Stack frame for lambda\n", stderr ); - dump_frame( stderr, next ); -#endif - 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 ); -#ifdef DEBUG - fputws( L"Stack frame for nlambda\n", stderr ); - dump_frame( stderr, next ); -#endif - 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; } @@ -352,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; } @@ -378,19 +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] ); -#ifdef DEBUG - fputws( L"Eval: ", stderr ); - dump_frame( stderr, frame ); -#endif - switch ( cell.tag.value ) { case CONSTV: { - result = c_apply( frame, env ); + result = c_apply( frame, frame_pointer, env ); } break; @@ -401,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 ); @@ -423,11 +442,8 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) { break; } -#ifdef DEBUG - fputws( L"Eval returning ", stderr ); - print( stderr, result ); - fputws( L"\n", stderr ); -#endif + debug_print( L"Eval returning ", DEBUG_EVAL ); + debug_dump_object( result, DEBUG_EVAL ); return result; } @@ -441,21 +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 ) { +lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { #ifdef DEBUG - fputws( L"Apply: ", stderr ); - dump_frame( stderr, frame ); + 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 ); - struct cons_pointer result = c_apply( frame, env ); + struct cons_pointer result = c_apply( frame, frame_pointer, env ); -#ifdef DEBUG - fputws( L"Apply returning ", stderr ); - print( stderr, result ); - fputws( L"\n", stderr ); -#endif + debug_print( L"Apply returning ", DEBUG_EVAL ); + debug_dump_object( result, DEBUG_EVAL ); return result; } @@ -469,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]; } @@ -484,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]; @@ -496,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; @@ -514,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; @@ -543,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; @@ -567,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] ) ) { @@ -578,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; @@ -591,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] ) ) { @@ -602,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; @@ -614,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] ); } @@ -623,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; } @@ -632,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; } @@ -643,14 +669,22 @@ 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; } @@ -684,6 +718,7 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) { * 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] ); } @@ -696,19 +731,24 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, * 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 ); result = print( output, frame->arg[0] ); - fputws( L"Print returning ", stderr ); - print( stderr, result ); - fputws( L"\n", stderr ); + debug_print( L"lisp_print returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); return result; } @@ -721,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] ); } @@ -739,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 ); } @@ -766,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 ); @@ -793,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 @@ -805,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 ); @@ -823,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/ops/lispops.h b/src/ops/lispops.h index 961cf2e..a1dee81 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -51,6 +51,7 @@ struct cons_pointer c_reverse( 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 ); @@ -60,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 ); @@ -68,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. @@ -89,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 ); /** @@ -98,31 +106,42 @@ 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_reverse( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); /** * Function: Get the Lisp type of the single argument. @@ -131,7 +150,8 @@ struct cons_pointer lisp_reverse( 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 ); /** @@ -145,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 @@ -157,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/ops/print.c b/src/ops/print.c index 4ec5a15..49adca7 100644 --- a/src/ops/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 ); @@ -118,12 +119,7 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { case EXCEPTIONTV: fwprintf( output, L"\n%sException: ", print_use_colours ? "\x1B[31m" : "" ); - if ( stringp( cell.payload.exception.message ) ) { - print_string_contents( output, - cell.payload.exception.message ); - } else { - print( output, cell.payload.exception.message ); - } + dump_stack_trace( output, pointer ); break; case FUNCTIONTV: fwprintf( output, L"(Function)" ); @@ -135,19 +131,19 @@ struct cons_pointer 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 ); @@ -194,6 +190,9 @@ struct cons_pointer 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", diff --git a/src/ops/read.c b/src/ops/read.c index bd063b2..a9b1ffe 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -18,6 +18,8 @@ #include #include "consspaceobject.h" +#include "debug.h" +#include "dump.h" #include "integer.h" #include "intern.h" #include "lispops.h" @@ -25,6 +27,7 @@ #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 @@ -32,9 +35,12 @@ * atoms because I don't yet know what an atom is or how it's stored. */ -struct cons_pointer read_number( struct stack_frame *frame, FILE * input, - wint_t initial, bool seen_period ); -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 ); @@ -43,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 ) ); } @@ -52,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; @@ -63,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 ';': @@ -72,16 +80,19 @@ 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 ) ); @@ -90,7 +101,9 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, wint_t next = fgetwc( input ); ungetwc( next, input ); if ( iswdigit( next ) ) { - result = read_number( frame, input, c, false ); + result = + read_number( frame, frame_pointer, input, c, + false ); } else { result = read_symbol( input, c ); } @@ -101,12 +114,15 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, wint_t next = fgetwc( input ); if ( iswdigit( next ) ) { ungetwc( next, input ); - result = read_number( frame, input, c, true ); + 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 ); } @@ -114,19 +130,22 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, break; default: if ( iswdigit( c ) ) { - result = read_number( frame, input, c, false ); + result = + read_number( frame, frame_pointer, input, c, false ); } else if ( iswprint( c ) ) { result = read_symbol( input, c ); } else { result = - make_exception( make_cons( c_string_to_lisp_string - ( "Unrecognised start of input character" ), + throw_exception( make_cons( c_string_to_lisp_string + ( L"Unrecognised start of input character" ), make_string( c, NIL ) ), - frame ); + frame_pointer ); } break; } } + debug_print( L"read_continuation returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); return result; } @@ -136,8 +155,11 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, * 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( 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 ) { + debug_print( L"entering read_number\n", DEBUG_IO ); struct cons_pointer result = NIL; int64_t accumulator = 0; int64_t dividend = 0; @@ -148,24 +170,24 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, if ( negative ) { initial = fgetwc( input ); } -#ifdef DEBUG - fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); -#endif + + debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial ); + for ( c = initial; iswdigit( c ) || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) { if ( c == btowc( '.' ) ) { if ( seen_period || dividend != 0 ) { - return make_exception( c_string_to_lisp_string - ( "Malformed number: too many periods" ), - frame ); + 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 make_exception( c_string_to_lisp_string - ( "Malformed number: dividend of rational must be integer" ), - frame ); + 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; @@ -173,11 +195,11 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, } } else { accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); -#ifdef DEBUG - fwprintf( stderr, + + debug_printf( DEBUG_IO, L"Added character %c, accumulator now %ld\n", c, accumulator ); -#endif + if ( seen_period ) { places_of_decimals++; } @@ -194,13 +216,10 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, if ( negative ) { rv = 0 - rv; } -#ifdef DEBUG - fwprintf( stderr, L"read_numer returning %Lf\n", rv ); -#endif result = make_real( rv ); } else if ( dividend != 0 ) { result = - make_ratio( frame, make_integer( dividend ), + make_ratio( frame_pointer, make_integer( dividend ), make_integer( accumulator ) ); } else { if ( negative ) { @@ -209,6 +228,9 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, result = make_integer( accumulator ); } + debug_print( L"read_number returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + return result; } @@ -216,24 +238,23 @@ struct cons_pointer read_number( struct stack_frame *frame, FILE * input, * 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 != ')' ) { -#ifdef DEBUG - fwprintf( stderr, + debug_printf( DEBUG_IO, L"read_list starting '%C' (%d)\n", initial, initial ); -#endif - 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 { + debug_print( L"End of list detected\n", DEBUG_IO ); } -#ifdef DEBUG - else { - fwprintf( stderr, L"End of list detected\n" ); - } -#endif return result; } @@ -304,11 +325,8 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { break; } -#ifdef DEBUG - fputws( L"Read symbol '", stderr ); - print( stderr, result ); - fputws( L"'\n", stderr ); -#endif + debug_print( L"read_symbol returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); return result; } @@ -318,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/ops/read.h b/src/ops/read.h index af7574b..c6dbba3 100644 --- a/src/ops/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/repl.c b/src/repl.c index f9ca5d5..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 ); - - set_reg( frame, 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; - set_reg( frame, 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 ); - - set_reg( frame, 0, value ); - set_reg( frame, 1, 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,12 +88,12 @@ 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 ); - pointer2cell( input_stream ).count = MAXREFERENCE; + inc_ref( input_stream ); struct cons_pointer output_stream = make_write_stream( out_stream ); - pointer2cell( output_stream ).count = MAXREFERENCE; - + inc_ref( output_stream ); while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) { if ( show_prompt ) { fwprintf( out_stream, L"\n:: " ); @@ -106,4 +113,5 @@ repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, } dec_ref( input ); } + debug_print( L"Leaving repl\n", DEBUG_REPL ); } 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); + } +}