simon/post-scarcity
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Merge branch 'release/0.0.4'

Browse source
This commit is contained in:
Simon Brooke 2018-12-28 22:36:43 +00:00
parent 614e20ab45 2d5fc4a202
commit 4033dbc82a
No known key found for this signature in database
GPG key ID: A7A4F18D1D4DF987
53 changed files with 2872 additions and 1002 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
.gitignore vendored
View file

@ -28,3 +28,13 @@ log*
\.project \.project
\.settings/language\.settings\.xml \.settings/language\.settings\.xml
utils_src/readprintwc/out
.kdev4/
.vscode/
hi.*
post-scarcity.kdev4

138
Doxyfile
View file

@ -32,13 +32,13 @@ DOXYFILE_ENCODING = UTF-8
# title of most generated pages and in a few other places. # title of most generated pages and in a few other places.
# The default value is: My Project. # 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 # 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 # could be handy for archiving the generated documentation or if some version
# control system is used. # control system is used.
PROJECT_NUMBER = PROJECT_NUMBER =
# Using the PROJECT_BRIEF tag one can provide an optional one line description # 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 # 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 # pixels and the maximum width should not exceed 200 pixels. Doxygen will copy
# the logo to the output directory. # the logo to the output directory.
PROJECT_LOGO = PROJECT_LOGO =
# The OUTPUT_DIRECTORY tag is used to specify the (relative or absolute) path # 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 # 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 # entered, it will be relative to the location where doxygen was started. If
# left blank the current directory will be used. # 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- # 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 # 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. # will be relative from the directory where doxygen is started.
# This tag requires that the tag FULL_PATH_NAMES is set to YES. # 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 # 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 # 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 # specify the list of include paths that are normally passed to the compiler
# using the -I flag. # 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 # 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 # 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 # "Side Effects:". You can put \n's in the value part of an alias to insert
# newlines. # newlines.
ALIASES = ALIASES =
# This tag can be used to specify a number of word-keyword mappings (TCL only). # 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" # 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. # 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 # 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 # 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 # Note that for custom extensions you also need to set FILE_PATTERNS otherwise
# the files are not read by doxygen. # the files are not read by doxygen.
EXTENSION_MAPPING = EXTENSION_MAPPING =
# If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments # If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments
# according to the Markdown format, which allows for more readable # according to the Markdown format, which allows for more readable
@ -648,7 +648,7 @@ GENERATE_DEPRECATEDLIST= YES
# sections, marked by \if <section_label> ... \endif and \cond <section_label> # sections, marked by \if <section_label> ... \endif and \cond <section_label>
# ... \endcond blocks. # ... \endcond blocks.
ENABLED_SECTIONS = ENABLED_SECTIONS =
# The MAX_INITIALIZER_LINES tag determines the maximum number of lines that the # 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 # 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 # by doxygen. Whatever the program writes to standard output is used as the file
# version. For an example see the documentation. # 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 # 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 # 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 # DoxygenLayout.xml, doxygen will parse it automatically even if the LAYOUT_FILE
# tag is left empty. # 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 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 # 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 # 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. # 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 # 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 # messages should be written. If left blank the output is written to standard
# error (stderr). # error (stderr).
WARN_LOGFILE = WARN_LOGFILE = doxy.log
#--------------------------------------------------------------------------- #---------------------------------------------------------------------------
# Configuration options related to the input files # Configuration options related to the input files
@ -790,7 +790,7 @@ WARN_LOGFILE =
# spaces. See also FILE_PATTERNS and EXTENSION_MAPPING # spaces. See also FILE_PATTERNS and EXTENSION_MAPPING
# Note: If this tag is empty the current directory is searched. # 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 # 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 # 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 # Note that relative paths are relative to the directory from which doxygen is
# run. # run.
EXCLUDE = EXCLUDE =
# The EXCLUDE_SYMLINKS tag can be used to select whether or not files or # 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 # 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 # 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 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 # The EXCLUDE_SYMBOLS tag can be used to specify one or more symbol names
# (namespaces, classes, functions, etc.) that should be excluded from the # (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 # Note that the wildcards are matched against the file with absolute path, so to
# exclude all test directories use the pattern */test/* # 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 # 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 # that contain example code fragments that are included (see the \include
# command). # command).
EXAMPLE_PATH = EXAMPLE_PATH =
# If the value of the EXAMPLE_PATH tag contains directories, you can use the # 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 # 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 # that contain images that are to be included in the documentation (see the
# \image command). # \image command).
IMAGE_PATH = IMAGE_PATH =
# The INPUT_FILTER tag can be used to specify a program that doxygen should # 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 # 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 # need to set EXTENSION_MAPPING for the extension otherwise the files are not
# properly processed by doxygen. # properly processed by doxygen.
INPUT_FILTER = INPUT_FILTER =
# The FILTER_PATTERNS tag can be used to specify filters on a per file pattern # 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 # 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 # need to set EXTENSION_MAPPING for the extension otherwise the files are not
# properly processed by doxygen. # properly processed by doxygen.
FILTER_PATTERNS = FILTER_PATTERNS =
# If the FILTER_SOURCE_FILES tag is set to YES, the input filter (if set using # 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 # 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). # *.ext= (so without naming a filter).
# This tag requires that the tag FILTER_SOURCE_FILES is set to YES. # 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 # 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 # 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 # (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. # 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 # Configuration options related to source browsing
@ -1087,7 +1087,7 @@ CLANG_ASSISTED_PARSING = NO
# specified with INPUT and INCLUDE_PATH. # specified with INPUT and INCLUDE_PATH.
# This tag requires that the tag CLANG_ASSISTED_PARSING is set to YES. # 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 # Configuration options related to the alphabetical class index
@ -1113,7 +1113,7 @@ COLS_IN_ALPHA_INDEX = 5
# while generating the index headers. # while generating the index headers.
# This tag requires that the tag ALPHABETICAL_INDEX is set to YES. # This tag requires that the tag ALPHABETICAL_INDEX is set to YES.
IGNORE_PREFIX = IGNORE_PREFIX =
#--------------------------------------------------------------------------- #---------------------------------------------------------------------------
# Configuration options related to the HTML output # 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. # of the possible markers and block names see the documentation.
# This tag requires that the tag GENERATE_HTML is set to YES. # 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 # 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 # generated HTML page. If the tag is left blank doxygen will generate a standard
@ -1167,7 +1167,7 @@ HTML_HEADER =
# that doxygen normally uses. # that doxygen normally uses.
# This tag requires that the tag GENERATE_HTML is set to YES. # 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 # 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 # 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. # obsolete.
# This tag requires that the tag GENERATE_HTML is set to YES. # 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 # The HTML_EXTRA_STYLESHEET tag can be used to specify additional user-defined
# cascading style sheets that are included after the standard style sheets # cascading style sheets that are included after the standard style sheets
@ -1192,7 +1192,7 @@ HTML_STYLESHEET =
# list). For an example see the documentation. # list). For an example see the documentation.
# This tag requires that the tag GENERATE_HTML is set to YES. # 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 # 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 # 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. # 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. # 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 # 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 # 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. # written to the html output directory.
# This tag requires that the tag GENERATE_HTMLHELP is set to YES. # 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 # 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, # 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. # The file has to be specified with full path.
# This tag requires that the tag GENERATE_HTMLHELP is set to YES. # 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 # 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). # (YES) or that it should be included in the master .chm file (NO).
@ -1352,7 +1352,7 @@ GENERATE_CHI = NO
# and project file content. # and project file content.
# This tag requires that the tag GENERATE_HTMLHELP is set to YES. # 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 # 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 # (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. # the HTML output folder.
# This tag requires that the tag GENERATE_QHP is set to YES. # 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 # The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help
# Project output. For more information please see Qt Help Project / Namespace # Project output. For more information please see Qt Help Project / Namespace
@ -1408,7 +1408,7 @@ QHP_VIRTUAL_FOLDER = doc
# filters). # filters).
# This tag requires that the tag GENERATE_QHP is set to YES. # 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 # 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 # custom filter to add. For more information please see Qt Help Project / Custom
@ -1416,21 +1416,21 @@ QHP_CUST_FILTER_NAME =
# filters). # filters).
# This tag requires that the tag GENERATE_QHP is set to YES. # 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 # The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this
# project's filter section matches. Qt Help Project / Filter Attributes (see: # project's filter section matches. Qt Help Project / Filter Attributes (see:
# http://qt-project.org/doc/qt-4.8/qthelpproject.html#filter-attributes). # http://qt-project.org/doc/qt-4.8/qthelpproject.html#filter-attributes).
# This tag requires that the tag GENERATE_QHP is set to YES. # 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 # 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 # qhelpgenerator. If non-empty doxygen will try to run qhelpgenerator on the
# generated .qhp file. # generated .qhp file.
# This tag requires that the tag GENERATE_QHP is set to YES. # 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 # 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 # 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 # MATHJAX_EXTENSIONS = TeX/AMSmath TeX/AMSsymbols
# This tag requires that the tag USE_MATHJAX is set to YES. # 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 # 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 # 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. # example see the documentation.
# This tag requires that the tag USE_MATHJAX is set to YES. # 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 # 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 # the HTML output. The underlying search engine uses javascript and DHTML and
@ -1631,7 +1631,7 @@ EXTERNAL_SEARCH = NO
# Searching" for details. # Searching" for details.
# This tag requires that the tag SEARCHENGINE is set to YES. # 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 # 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 # 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. # projects and redirect the results back to the right project.
# This tag requires that the tag SEARCHENGINE is set to YES. # 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 # 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 # 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 ... # EXTRA_SEARCH_MAPPINGS = tagname1=loc1 tagname2=loc2 ...
# This tag requires that the tag SEARCHENGINE is set to YES. # This tag requires that the tag SEARCHENGINE is set to YES.
EXTRA_SEARCH_MAPPINGS = EXTRA_SEARCH_MAPPINGS =
#--------------------------------------------------------------------------- #---------------------------------------------------------------------------
# Configuration options related to the LaTeX output # Configuration options related to the LaTeX output
@ -1721,7 +1721,7 @@ PAPER_TYPE = a4
# If left blank no extra packages will be included. # If left blank no extra packages will be included.
# This tag requires that the tag GENERATE_LATEX is set to YES. # 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 # 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 # generated LaTeX document. The header should contain everything until the first
@ -1737,7 +1737,7 @@ EXTRA_PACKAGES =
# to HTML_HEADER. # to HTML_HEADER.
# This tag requires that the tag GENERATE_LATEX is set to YES. # 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 # 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 # 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! # 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. # 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 # 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 # LaTeX style sheets that are included after the standard style sheets created
@ -1759,7 +1759,7 @@ LATEX_FOOTER =
# list). # list).
# This tag requires that the tag GENERATE_LATEX is set to YES. # 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 # 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 # other source files which should be copied to the LATEX_OUTPUT output
@ -1767,7 +1767,7 @@ LATEX_EXTRA_STYLESHEET =
# markers available. # markers available.
# This tag requires that the tag GENERATE_LATEX is set to YES. # 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 # 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 # 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. # default style sheet that doxygen normally uses.
# This tag requires that the tag GENERATE_RTF is set to YES. # 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 # 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 # similar to doxygen's config file. A template extensions file can be generated
# using doxygen -e rtf extensionFile. # using doxygen -e rtf extensionFile.
# This tag requires that the tag GENERATE_RTF is set to YES. # 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 # If the RTF_SOURCE_CODE tag is set to YES then doxygen will include source code
# with syntax highlighting in the RTF output. # with syntax highlighting in the RTF output.
@ -1927,7 +1927,7 @@ MAN_EXTENSION = .3
# MAN_EXTENSION with the initial . removed. # MAN_EXTENSION with the initial . removed.
# This tag requires that the tag GENERATE_MAN is set to YES. # 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 # 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 # 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. # overwrite each other's variables.
# This tag requires that the tag GENERATE_PERLMOD is set to YES. # This tag requires that the tag GENERATE_PERLMOD is set to YES.
PERLMOD_MAKEVAR_PREFIX = PERLMOD_MAKEVAR_PREFIX =
#--------------------------------------------------------------------------- #---------------------------------------------------------------------------
# Configuration options related to the preprocessor # Configuration options related to the preprocessor
@ -2081,7 +2081,7 @@ SEARCH_INCLUDES = YES
# preprocessor. # preprocessor.
# This tag requires that the tag SEARCH_INCLUDES is set to YES. # 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 # 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 # patterns (like *.h and *.hpp) to filter out the header-files in the
@ -2089,7 +2089,7 @@ INCLUDE_PATH =
# used. # used.
# This tag requires that the tag ENABLE_PREPROCESSING is set to YES. # 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 # 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. # 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. # recursively expanded use the := operator instead of the = operator.
# This tag requires that the tag ENABLE_PREPROCESSING is set to YES. # 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 # 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 # 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. # definition found in the source code.
# This tag requires that the tag ENABLE_PREPROCESSING is set to YES. # 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 # 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 # 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 # 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. # 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 # 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 # 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. # 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 # 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 # 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 # the mscgen tool resides. If left empty the tool is assumed to be found in the
# default search path. # default search path.
MSCGEN_PATH = MSCGEN_PATH =
# You can include diagrams made with dia in doxygen documentation. Doxygen will # 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 # 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. # 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. # 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 # 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. # 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. # the path where dot can find it using this tag.
# This tag requires that the tag HAVE_DOT is set to YES. # 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 # 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. # 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. # 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. # 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 # 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 # contain dot files that are included in the documentation (see the \dotfile
# command). # command).
# This tag requires that the tag HAVE_DOT is set to YES. # 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 # 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 # contain msc files that are included in the documentation (see the \mscfile
# command). # command).
MSCFILE_DIRS = MSCFILE_DIRS =
# The DIAFILE_DIRS tag can be used to specify one or more directories that # 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 # contain dia files that are included in the documentation (see the \diafile
# command). # command).
DIAFILE_DIRS = DIAFILE_DIRS =
# When using plantuml, the PLANTUML_JAR_PATH tag should be used to specify the # 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 # 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 # generate a warning when it encounters a \startuml command in this case and
# will not generate output for the diagram. # 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 # When using plantuml, the PLANTUML_CFG_FILE tag can be used to specify a
# configuration file for plantuml. # configuration file for plantuml.
PLANTUML_CFG_FILE = PLANTUML_CFG_FILE =
# When using plantuml, the specified paths are searched for files specified by # When using plantuml, the specified paths are searched for files specified by
# the !include statement in a plantuml block. # 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 # 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 # that will be shown in the graph. If the number of nodes in a graph becomes

6
Makefile
View file

@ -17,13 +17,13 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \
VERSION := "0.0.2" VERSION := "0.0.2"
CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG
LDFLAGS := -lm LDFLAGS := -lm
$(TARGET): $(OBJS) Makefile $(TARGET): $(OBJS) Makefile
$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS)
doc: $(SRCS) Makefile doc: $(SRCS) Makefile Doxyfile
doxygen doxygen
format: $(SRCS) $(HDRS) Makefile format: $(SRCS) $(HDRS) Makefile
@ -38,7 +38,7 @@ test: $(OBJS) $(TESTS) Makefile
.PHONY: clean .PHONY: clean
clean: clean:
$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ *~ $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~
repl: repl:
$(TARGET) -p 2> psse.log $(TARGET) -p 2> psse.log

8
lisp/defun.lisp
View file

@ -1,10 +1,12 @@
;; Because I don't (yet) have syntax for varargs, the body must be passed (set! list (lambda l l))
;; to defun as a list of sexprs.
(set! symbolp (lambda (x) (equal (type x) "SYMB")))
(set! defun! (set! defun!
(nlambda (nlambda
form form
(cond ((symbolp (car form)) (cond ((symbolp (car form))
(set (car form) (apply lambda (cdr form)))) (set (car form) (apply 'lambda (cdr form))))
(t nil)))) (t nil))))
(defun! square (x) (* x x)) (defun! square (x) (* x x))

14
src/arith/bignum.c Normal file
View file

@ -0,0 +1,14 @@
/*
* bignum.c
*
* Allocation of and operations on arbitrary precision integers.
*
* (c) 2018 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
/*
* Bignums generally follow Knuth, vol 2, 4.3. The word size is 64 bits,
* and words are stored in individual cons-space objects, comprising the
* word itself and a pointer to the next word in the number.
*/

16
src/arith/bignum.h Normal file
View file

@ -0,0 +1,16 @@
/**
* bignum.h
*
* functions for bignum cells.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __bignum_h
#define __bignum_h
#endif

6
src/integer.c → src/arith/integer.c
View file

@ -13,7 +13,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "read.h" #include "debug.h"
/** /**
* return the numeric value of this cell, as a C primitive double, not * return the numeric value of this cell, as a C primitive double, not
@ -36,12 +36,12 @@ long double numeric_value( struct cons_pointer pointer ) {
/** /**
* Allocate an integer cell representing this value and return a cons pointer to it. * Allocate an integer cell representing this value and return a cons pointer to it.
*/ */
struct cons_pointer make_integer( long int value ) { struct cons_pointer make_integer( int64_t value ) {
struct cons_pointer result = allocate_cell( INTEGERTAG ); struct cons_pointer result = allocate_cell( INTEGERTAG );
struct cons_space_object *cell = &pointer2cell( result ); struct cons_space_object *cell = &pointer2cell( result );
cell->payload.integer.value = value; cell->payload.integer.value = value;
dump_object( stderr, result ); debug_dump_object( result, DEBUG_ARITH );
return result; return result;
} }

2
src/integer.h → src/arith/integer.h
View file

@ -16,6 +16,6 @@ long double numeric_value( struct cons_pointer pointer );
/** /**
* Allocate an integer cell representing this value and return a cons pointer to it. * Allocate an integer cell representing this value and return a cons pointer to it.
*/ */
struct cons_pointer make_integer( long int value ); struct cons_pointer make_integer( int64_t value );
#endif #endif

636
src/arith/peano.c Normal file
View file

@ -0,0 +1,636 @@
/*
* peano.c
*
* Basic peano arithmetic
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <math.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "debug.h"
#include "equal.h"
#include "integer.h"
#include "intern.h"
#include "lispops.h"
#include "print.h"
#include "ratio.h"
#include "read.h"
#include "real.h"
#include "stack.h"
long double to_long_double( struct cons_pointer arg );
int64_t to_long_int( struct cons_pointer arg );
struct cons_pointer add_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );
bool zerop( struct cons_pointer arg ) {
bool result = false;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
result = cell.payload.integer.value == 0;
break;
case RATIOTV:
result = zerop( cell.payload.ratio.dividend );
break;
case REALTV:
result = ( cell.payload.real.value == 0 );
break;
}
return result;
}
/**
* TODO: cannot throw an exception out of here, which is a problem
* if a ratio may legally have zero as a divisor, or something which is
* not a number is passed in.
*/
long double to_long_double( struct cons_pointer arg ) {
long double result = 0; /* not a number, as a long double */
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
result = ( double ) cell.payload.integer.value;
break;
case RATIOTV:
{
struct cons_space_object dividend =
pointer2cell( cell.payload.ratio.dividend );
struct cons_space_object divisor =
pointer2cell( cell.payload.ratio.divisor );
result =
( long double ) dividend.payload.integer.value /
divisor.payload.integer.value;
}
break;
case REALTV:
result = cell.payload.real.value;
break;
default:
result = NAN;
break;
}
debug_print( L"to_long_double( ", DEBUG_ARITH );
debug_print_object( arg, DEBUG_ARITH );
debug_printf( DEBUG_ARITH, L") => %lf\n", result );
return result;
}
/**
* TODO: cannot throw an exception out of here, which is a problem
* if a ratio may legally have zero as a divisor, or something which is
* not a number (or is a big number) is passed in.
*/
int64_t to_long_int( struct cons_pointer arg ) {
int64_t result = 0;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
result = cell.payload.integer.value;
break;
case RATIOTV:
result = lroundl( to_long_double( arg ) );
break;
case REALTV:
result = lroundl( cell.payload.real.value );
break;
}
return result;
}
/**
* return a cons_pointer indicating a number which is the sum of
* the numbers indicated by `arg1` and `arg2`.
*/
struct cons_pointer add_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer result;
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
debug_print( L"add_2( arg1 = ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
if ( zerop( arg1 ) ) {
result = arg2;
} else if ( zerop( arg2 ) ) {
result = arg1;
} else {
switch ( cell1.tag.value ) {
case EXCEPTIONTV:
result = arg1;
break;
case INTEGERTV:
switch ( cell2.tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:
result = make_integer( cell1.payload.integer.value +
cell2.payload.integer.value );
break;
case RATIOTV:
result =
add_integer_ratio( frame_pointer, arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) +
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot add: not a number" ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( cell2.tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:
result =
add_integer_ratio( frame_pointer, arg2, arg1 );
break;
case RATIOTV:
result = add_ratio_ratio( frame_pointer, arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) +
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot add: not a number" ),
frame_pointer );
break;
}
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) +
to_long_double( arg2 ) );
break;
default:
result = exceptionp( arg2 ) ? arg2 :
throw_exception( c_string_to_lisp_string
( L"Cannot add: not a number" ),
frame_pointer );
}
}
debug_print( L"}; => ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
/**
* Add an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer lisp_add( struct stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = make_integer( 0 );
struct cons_pointer tmp;
for ( int i = 0;
i < args_in_frame &&
!nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) {
tmp = result;
result = add_2( frame, frame_pointer, result, frame->arg[i] );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
}
struct cons_pointer more = frame->more;
while ( consp( more ) && !exceptionp( result ) ) {
tmp = result;
result = add_2( frame, frame_pointer, result, c_car( more ) );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
more = c_cdr( more );
}
return result;
}
/**
* return a cons_pointer indicating a number which is the product of
* the numbers indicated by `arg1` and `arg2`.
*/
struct cons_pointer multiply_2( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer result;
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
debug_print( L"multiply_2( arg1 = ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L")", DEBUG_ARITH );
if ( zerop( arg1 ) ) {
result = arg2;
} else if ( zerop( arg2 ) ) {
result = arg1;
} else {
switch ( cell1.tag.value ) {
case EXCEPTIONTV:
result = arg1;
break;
case INTEGERTV:
switch ( cell2.tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:
result = make_integer( cell1.payload.integer.value *
cell2.payload.integer.value );
break;
case RATIOTV:
result =
multiply_integer_ratio( frame_pointer, arg1,
arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) *
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot multiply: not a number" ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( cell2.tag.value ) {
case EXCEPTIONTV:
result = arg2;
break;
case INTEGERTV:
result =
multiply_integer_ratio( frame_pointer, arg2,
arg1 );
break;
case RATIOTV:
result =
multiply_ratio_ratio( frame_pointer, arg1, arg2 );
break;
case REALTV:
result =
make_real( to_long_double( arg1 ) *
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot multiply: not a number" ),
frame_pointer );
}
break;
case REALTV:
result = exceptionp( arg2 ) ? arg2 :
make_real( to_long_double( arg1 ) *
to_long_double( arg2 ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot multiply: not a number" ),
frame_pointer );
break;
}
}
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
/**
* Multiply an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer lisp_multiply( struct
stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = make_integer( 1 );
struct cons_pointer tmp;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] )
&& !exceptionp( result ); i++ ) {
tmp = result;
result = multiply_2( frame, frame_pointer, result, frame->arg[i] );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
}
struct cons_pointer more = frame->more;
while ( consp( more )
&& !exceptionp( result ) ) {
tmp = result;
result = multiply_2( frame, frame_pointer, result, c_car( more ) );
if ( !eq( tmp, result ) ) {
dec_ref( tmp );
}
more = c_cdr( more );
}
return result;
}
/**
* return a cons_pointer indicating a number which is the
* inverse of the number indicated by `arg`.
*/
struct cons_pointer inverse( struct cons_pointer frame,
struct cons_pointer arg ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case EXCEPTIONTV:
result = arg;
break;
case INTEGERTV:
result = make_integer( 0 - to_long_int( arg ) );
break;
case NILTV:
result = TRUE;
break;
case RATIOTV:
result = make_ratio( frame,
make_integer( 0 -
to_long_int( cell.payload.
ratio.dividend ) ),
cell.payload.ratio.divisor );
break;
case REALTV:
result = make_real( 0 - to_long_double( arg ) );
break;
case TRUETV:
result = NIL;
break;
}
return result;
}
/**
* Subtract one number from another.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer lisp_subtract( struct
stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object cell0 = pointer2cell( frame->arg[0] );
struct cons_space_object cell1 = pointer2cell( frame->arg[1] );
switch ( cell0.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[0];
break;
case INTEGERTV:
switch ( cell1.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[1];
break;
case INTEGERTV:
result = make_integer( cell0.payload.integer.value
- cell1.payload.integer.value );
break;
case RATIOTV:{
struct cons_pointer tmp =
make_ratio( frame_pointer, frame->arg[0],
make_integer( 1 ) );
inc_ref( tmp );
result =
subtract_ratio_ratio( frame_pointer, tmp,
frame->arg[1] );
dec_ref( tmp );
}
break;
case REALTV:
result =
make_real( to_long_double( frame->arg[0] ) -
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( cell1.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[1];
break;
case INTEGERTV:{
struct cons_pointer tmp =
make_ratio( frame_pointer, frame->arg[1],
make_integer( 1 ) );
inc_ref( tmp );
result =
subtract_ratio_ratio( frame_pointer, frame->arg[0],
tmp );
dec_ref( tmp );
}
break;
case RATIOTV:
result =
subtract_ratio_ratio( frame_pointer, frame->arg[0],
frame->arg[1] );
break;
case REALTV:
result =
make_real( to_long_double( frame->arg[0] ) -
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
break;
case REALTV:
result = exceptionp( frame->arg[1] ) ? frame->arg[1] :
make_real( to_long_double( frame->arg[0] ) -
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
}
// and if not nilp[frame->arg[2]) we also have an error.
return result;
}
/**
* Divide one number by another.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer lisp_divide( struct
stack_frame
*frame, struct cons_pointer frame_pointer, struct
cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
switch ( arg0.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[0];
break;
case INTEGERTV:
switch ( arg1.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[1];
break;
case INTEGERTV:{
struct cons_pointer unsimplified =
make_ratio( frame_pointer, frame->arg[0],
frame->arg[1] );
/* OK, if result may be unsimplified, we should not inc_ref it
* - but if not, we should dec_ref it. */
result = simplify_ratio( frame_pointer, unsimplified );
if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified );
}
}
break;
case RATIOTV:{
struct cons_pointer one = make_integer( 1 );
struct cons_pointer ratio =
make_ratio( frame_pointer, frame->arg[0], one );
result =
divide_ratio_ratio( frame_pointer, ratio,
frame->arg[1] );
dec_ref( ratio );
}
break;
case REALTV:
result =
make_real( to_long_double( frame->arg[0] ) /
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
break;
case RATIOTV:
switch ( arg1.tag.value ) {
case EXCEPTIONTV:
result = frame->arg[1];
break;
case INTEGERTV:{
struct cons_pointer one = make_integer( 1 );
inc_ref( one );
struct cons_pointer ratio =
make_ratio( frame_pointer, frame->arg[1], one );
inc_ref( ratio );
result =
divide_ratio_ratio( frame_pointer, frame->arg[0],
ratio );
dec_ref( ratio );
dec_ref( one );
}
break;
case RATIOTV:
result =
divide_ratio_ratio( frame_pointer, frame->arg[0],
frame->arg[1] );
break;
case REALTV:
result =
make_real( to_long_double( frame->arg[0] ) /
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
break;
case REALTV:
result = exceptionp( frame->arg[1] ) ? frame->arg[1] :
make_real( to_long_double( frame->arg[0] ) /
to_long_double( frame->arg[1] ) );
break;
default:
result = throw_exception( c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
}
return result;
}

14
src/peano.h → src/arith/peano.h
View file

@ -23,7 +23,8 @@ extern "C" {
* @return a pointer to an integer or real. * @return a pointer to an integer or real.
*/ */
struct cons_pointer 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 * Multiply an indefinite number of numbers together
@ -32,7 +33,9 @@ extern "C" {
* @return a pointer to an integer or real. * @return a pointer to an integer or real.
*/ */
struct cons_pointer 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. * Subtract one number from another.
@ -41,7 +44,9 @@ extern "C" {
* @return a pointer to an integer or real. * @return a pointer to an integer or real.
*/ */
struct cons_pointer 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. * Divide one number by another.
@ -50,7 +55,8 @@ extern "C" {
* @return a pointer to an integer or real. * @return a pointer to an integer or real.
*/ */
struct cons_pointer 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 #ifdef __cplusplus
} }

333
src/arith/ratio.c Normal file
View file

@ -0,0 +1,333 @@
/*
* ratio.c
*
* functions for rational number cells.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#define _GNU_SOURCE
#include <math.h>
#include <stdio.h>
#include "conspage.h"
#include "consspaceobject.h"
#include "debug.h"
#include "equal.h"
#include "integer.h"
#include "lispops.h"
#include "print.h"
#include "ratio.h"
/*
* declared in peano.c, can't include piano.h here because
* circularity. TODO: refactor.
*/
struct cons_pointer inverse( struct cons_pointer frame_pointer,
struct cons_pointer arg );
/**
* return, as a int64_t, the greatest common divisor of `m` and `n`,
*/
int64_t greatest_common_divisor( int64_t m, int64_t n ) {
int o;
while ( m ) {
o = m;
m = n % m;
n = o;
}
return o;
}
/**
* return, as a int64_t, the least common multiple of `m` and `n`,
*/
int64_t least_common_multiple( int64_t m, int64_t n ) {
return m / greatest_common_divisor( m, n ) * n;
}
/**
* return a cons_pointer indicating a number which is of the
* same value as the ratio indicated by `arg`, but which may
* be in a simplified representation. If `arg` isn't a ratio,
* will throw exception.
*/
struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg ) {
struct cons_pointer result = arg;
if ( ratiop( arg ) ) {
int64_t ddrv =
pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).
payload.integer.value, drrv =
pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).
payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv );
if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) {
result = make_integer( ddrv / gcd );
} else {
result =
make_ratio( frame_pointer, make_integer( ddrv / gcd ),
make_integer( drrv / gcd ) );
}
}
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to simplify_ratio" ),
arg ), frame_pointer );
}
return result;
}
/**
* return a cons_pointer indicating a number which is the sum of
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
* this is going to break horribly.
*/
struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer r, result;
debug_print( L"add_ratio_ratio( arg1 = ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L")\n", DEBUG_ARITH );
if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
int64_t dd1v =
pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
dd2v =
pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value,
dr1v =
pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value,
dr2v =
pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
lcm = least_common_multiple( dr1v, dr2v ),
m1 = lcm / dr1v, m2 = lcm / dr2v;
debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 );
if ( dr1v == dr2v ) {
r = make_ratio( frame_pointer,
make_integer( dd1v + dd2v ),
cell1.payload.ratio.divisor );
} else {
struct cons_pointer dd1vm = make_integer( dd1v * m1 ),
dr1vm = make_integer( dr1v * m1 ),
dd2vm = make_integer( dd2v * m2 ),
dr2vm = make_integer( dr2v * m2 ),
r1 = make_ratio( frame_pointer, dd1vm, dr1vm ),
r2 = make_ratio( frame_pointer, dd2vm, dr2vm );
r = add_ratio_ratio( frame_pointer, r1, r2 );
/* because the references on dd1vm, dr1vm, dd2vm and dr2vm were
* never incremented except when making r1 and r2, decrementing
* r1 and r2 should be enought to garbage collect them. */
dec_ref( r1 );
dec_ref( r2 );
}
result = simplify_ratio( frame_pointer, r );
if ( !eq( r, result ) ) {
dec_ref( r );
}
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1,
make_cons( arg2, NIL ) ) ),
frame_pointer );
}
debug_print( L" => ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
return result;
}
/**
* return a cons_pointer indicating a number which is the sum of
* the intger indicated by `intarg` and the ratio indicated by
* `ratarg`. If you pass other types, this is going to break horribly.
*/
struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg,
struct cons_pointer ratarg ) {
struct cons_pointer result;
if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = make_integer( 1 ),
ratio = make_ratio( frame_pointer, intarg, one );
result = add_ratio_ratio( frame_pointer, ratio, ratarg );
dec_ref( one );
dec_ref( ratio );
} else {
result =
throw_exception( make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg,
make_cons( ratarg,
NIL ) ) ),
frame_pointer );
}
return result;
}
/**
* return a cons_pointer to a ratio which represents the value of the ratio
* indicated by `arg1` divided by the ratio indicated by `arg2`. If either
* of these aren't RTIO cells, something horrid will happen and it is YOUR FAULT.
*/
struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer i = make_ratio( frame_pointer,
pointer2cell( arg2 ).payload.
ratio.divisor,
pointer2cell( arg2 ).payload.
ratio.dividend ),
result =
multiply_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i );
return result;
}
/**
* return a cons_pointer indicating a number which is the product of
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
* this is going to break horribly.
*/
struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct
cons_pointer arg1, struct
cons_pointer arg2 ) {
struct cons_pointer result;
debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
debug_print( L")\n", DEBUG_ARITH );
if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
struct cons_space_object cell1 = pointer2cell( arg1 );
struct cons_space_object cell2 = pointer2cell( arg2 );
int64_t dd1v =
pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
dd2v =
pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value,
dr1v =
pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value,
dr2v =
pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
struct cons_pointer unsimplified =
make_ratio( frame_pointer, make_integer( ddrv ),
make_integer( drrv ) );
result = simplify_ratio( frame_pointer, unsimplified );
if ( !eq( unsimplified, result ) ) {
dec_ref( unsimplified );
}
} else {
result =
throw_exception( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ),
frame_pointer );
}
return result;
}
/**
* return a cons_pointer indicating a number which is the product of
* the intger indicated by `intarg` and the ratio indicated by
* `ratarg`. If you pass other types, this is going to break horribly.
*/
struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg,
struct cons_pointer ratarg ) {
struct cons_pointer result;
if ( integerp( intarg ) && ratiop( ratarg ) ) {
struct cons_pointer one = make_integer( 1 ),
ratio = make_ratio( frame_pointer, intarg, one );
result = multiply_ratio_ratio( frame_pointer, ratio, ratarg );
dec_ref( one );
dec_ref( ratio );
} else {
result =
throw_exception( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_integer_ratio" ),
frame_pointer );
}
return result;
}
/**
* return a cons_pointer indicating a number which is the difference of
* the ratios indicated by `arg1` and `arg2`. If you pass non-ratios,
* this is going to break horribly.
*/
struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 ) {
struct cons_pointer i = inverse( frame_pointer, arg2 ),
result = add_ratio_ratio( frame_pointer, arg1, i );
dec_ref( i );
return result;
}
/**
* Construct a ratio frame from these two pointers, expected to be integers
* or (later) bignums, in the context of this stack_frame.
*/
struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
struct cons_pointer dividend,
struct cons_pointer divisor ) {
struct cons_pointer result;
if ( integerp( dividend ) && integerp( divisor ) ) {
inc_ref( dividend );
inc_ref( divisor );
result = allocate_cell( RATIOTAG );
struct cons_space_object *cell = &pointer2cell( result );
cell->payload.ratio.dividend = dividend;
cell->payload.ratio.divisor = divisor;
} else {
result =
throw_exception( c_string_to_lisp_string
( L"Dividend and divisor of a ratio must be integers" ),
frame_pointer );
}
debug_dump_object( result, DEBUG_ARITH );
return result;
}

46
src/arith/ratio.h Normal file
View file

@ -0,0 +1,46 @@
/**
* ratio.h
*
* functions for rational number cells.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#ifndef __ratio_h
#define __ratio_h
struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg );
struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg,
struct cons_pointer ratarg );
struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct
cons_pointer arg1, struct
cons_pointer arg2 );
struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer,
struct cons_pointer intarg,
struct cons_pointer ratarg );
struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer,
struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer make_ratio( struct cons_pointer frame_pointer,
struct cons_pointer dividend,
struct cons_pointer divisor );
#endif

5
src/real.c → src/arith/real.c
View file

@ -9,10 +9,11 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "read.h" #include "read.h"
/** /**
* Allocate a real number cell representing this value and return a cons * Allocate a real number cell representing this value and return a cons
* pointer to it. * pointer to it.
* @param value the value to wrap; * @param value the value to wrap;
* @return a real number cell wrapping this value. * @return a real number cell wrapping this value.
@ -22,5 +23,7 @@ struct cons_pointer make_real( long double value ) {
struct cons_space_object *cell = &pointer2cell( result ); struct cons_space_object *cell = &pointer2cell( result );
cell->payload.real.value = value; cell->payload.real.value = value;
debug_dump_object( result, DEBUG_ARITH );
return result; return result;
} }

0
src/real.h → src/arith/real.h
View file

99
src/debug.c Normal file
View file

@ -0,0 +1,99 @@
/**
* debug.c
*
* Better debug log messages.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdarg.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#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
}

33
src/debug.h Normal file
View file

@ -0,0 +1,33 @@
/**
* debug.h
*
* Better debug log messages.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdio.h>
#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

90
src/init.c
View file

@ -11,26 +11,32 @@
#include <stdbool.h> #include <stdbool.h>
#include <stdio.h> #include <stdio.h>
#include <stdlib.h>
#include <unistd.h> #include <unistd.h>
#include <wchar.h> #include <wchar.h>
#include "version.h" #include "version.h"
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "intern.h" #include "intern.h"
#include "lispops.h" #include "lispops.h"
#include "peano.h" #include "peano.h"
#include "print.h" #include "print.h"
#include "repl.h" #include "repl.h"
void bind_function( char *name, struct cons_pointer ( *executable ) // extern char *optarg; /* defined in unistd.h */
( struct stack_frame *, struct cons_pointer ) ) {
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 ), deep_bind( c_string_to_lisp_symbol( name ),
make_function( NIL, executable ) ); make_function( NIL, executable ) );
} }
void bind_special( char *name, struct cons_pointer ( *executable ) void bind_special( wchar_t *name, struct cons_pointer ( *executable )
( struct stack_frame * frame, struct cons_pointer env ) ) { ( struct stack_frame *,
struct cons_pointer, struct cons_pointer ) ) {
deep_bind( c_string_to_lisp_symbol( name ), deep_bind( c_string_to_lisp_symbol( name ),
make_special( NIL, executable ) ); make_special( NIL, executable ) );
} }
@ -46,7 +52,7 @@ int main( int argc, char *argv[] ) {
bool dump_at_end = false; bool dump_at_end = false;
bool show_prompt = false; bool show_prompt = false;
while ( ( option = getopt( argc, argv, "pdc" ) ) != -1 ) { while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) {
switch ( option ) { switch ( option ) {
case 'c': case 'c':
print_use_colours = true; print_use_colours = true;
@ -57,6 +63,9 @@ int main( int argc, char *argv[] ) {
case 'p': case 'p':
show_prompt = true; show_prompt = true;
break; break;
case 'v':
verbosity = atoi( optarg );
break;
default: default:
fwprintf( stderr, L"Unexpected option %c\n", option ); fwprintf( stderr, L"Unexpected option %c\n", option );
break; break;
@ -69,51 +78,60 @@ int main( int argc, char *argv[] ) {
VERSION ); VERSION );
} }
debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP );
initialise_cons_pages( ); initialise_cons_pages( );
debug_print( L"Initialised cons pages, about to bind\n", DEBUG_BOOTSTRAP );
/* /*
* privileged variables (keywords) * privileged variables (keywords)
*/ */
deep_bind( c_string_to_lisp_symbol( "nil" ), NIL ); deep_bind( c_string_to_lisp_symbol( L"nil" ), NIL );
deep_bind( c_string_to_lisp_symbol( "t" ), TRUE ); deep_bind( c_string_to_lisp_symbol( L"t" ), TRUE );
/* /*
* primitive function operations * primitive function operations
*/ */
bind_function( "add", &lisp_add ); bind_function( L"add", &lisp_add );
bind_function( "apply", &lisp_apply ); bind_function( L"apply", &lisp_apply );
bind_function( "assoc", &lisp_assoc ); bind_function( L"assoc", &lisp_assoc );
bind_function( "car", &lisp_car ); bind_function( L"car", &lisp_car );
bind_function( "cdr", &lisp_cdr ); bind_function( L"cdr", &lisp_cdr );
bind_function( "cons", &lisp_cons ); bind_function( L"cons", &lisp_cons );
bind_function( "divide", &lisp_divide ); bind_function( L"divide", &lisp_divide );
bind_function( "eq", &lisp_eq ); bind_function( L"eq", &lisp_eq );
bind_function( "equal", &lisp_equal ); bind_function( L"equal", &lisp_equal );
bind_function( "eval", &lisp_eval ); bind_function( L"eval", &lisp_eval );
bind_function( "multiply", &lisp_multiply ); bind_function( L"exception", &lisp_exception );
bind_function( "read", &lisp_read ); bind_function( L"multiply", &lisp_multiply );
bind_function( "oblist", &lisp_oblist ); bind_function( L"read", &lisp_read );
bind_function( "print", &lisp_print ); bind_function( L"oblist", &lisp_oblist );
bind_function( "progn", &lisp_progn ); bind_function( L"print", &lisp_print );
bind_function( "set", &lisp_set ); bind_function( L"progn", &lisp_progn );
bind_function( "subtract", &lisp_subtract ); bind_function( L"reverse", &lisp_reverse );
bind_function( "type", &lisp_type ); 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( L"+", &lisp_add );
bind_function( "*", &lisp_multiply ); bind_function( L"*", &lisp_multiply );
bind_function( "-", &lisp_subtract ); bind_function( L"-", &lisp_subtract );
bind_function( "/", &lisp_divide ); bind_function( L"/", &lisp_divide );
bind_function( "=", &lisp_equal ); bind_function( L"=", &lisp_equal );
/* /*
* primitive special forms * primitive special forms
*/ */
bind_special( "cond", &lisp_cond ); bind_special( L"cond", &lisp_cond );
bind_special( "lambda", &lisp_lambda ); bind_special( L"lambda", &lisp_lambda );
bind_special( "nlambda", &lisp_nlambda ); // bind_special( L"λ", &lisp_lambda );
bind_special( "progn", &lisp_progn ); bind_special( L"nlambda", &lisp_nlambda );
bind_special( "quote", &lisp_quote ); // bind_special( L"nλ", &lisp_nlambda );
bind_special( "set!", &lisp_set_shriek ); 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 ); repl( stdin, stdout, stderr, show_prompt );

45
src/conspage.c → src/memory/conspage.c
View file

@ -18,6 +18,8 @@
#include "consspaceobject.h" #include "consspaceobject.h"
#include "conspage.h" #include "conspage.h"
#include "debug.h"
#include "dump.h"
/** /**
* Flag indicating whether conspage initialisation has been done. * Flag indicating whether conspage initialisation has been done.
@ -64,7 +66,7 @@ void make_cons_page( ) {
cell->count = MAXREFERENCE; cell->count = MAXREFERENCE;
cell->payload.free.car = NIL; cell->payload.free.car = NIL;
cell->payload.free.cdr = 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; break;
case 1: case 1:
/* /*
@ -78,7 +80,7 @@ void make_cons_page( ) {
cell->payload.free.cdr = ( struct cons_pointer ) { cell->payload.free.cdr = ( struct cons_pointer ) {
0, 1 0, 1
}; };
fwprintf( stderr, L"Allocated special cell T\n" ); debug_printf( DEBUG_ALLOC, L"Allocated special cell T\n" );
break; break;
} }
} else { } else {
@ -95,7 +97,7 @@ void make_cons_page( ) {
initialised_cons_pages++; initialised_cons_pages++;
} else { } else {
fwprintf( stderr, debug_printf( DEBUG_ALLOC,
L"FATAL: Failed to allocate memory for cons page %d\n", L"FATAL: Failed to allocate memory for cons page %d\n",
initialised_cons_pages ); initialised_cons_pages );
exit( 1 ); exit( 1 );
@ -127,6 +129,9 @@ void dump_pages( FILE * output ) {
void free_cell( struct cons_pointer pointer ) { void free_cell( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
debug_printf( DEBUG_ALLOC, L"Freeing cell " );
debug_dump_object( pointer, DEBUG_ALLOC );
switch ( cell->tag.value ) { switch ( cell->tag.value ) {
/* for all the types of cons-space object which point to other /* for all the types of cons-space object which point to other
* cons-space objects, cascade the decrement. */ * cons-space objects, cascade the decrement. */
@ -145,6 +150,10 @@ void free_cell( struct cons_pointer pointer ) {
dec_ref( cell->payload.lambda.args ); dec_ref( cell->payload.lambda.args );
dec_ref( cell->payload.lambda.body ); dec_ref( cell->payload.lambda.body );
break; break;
case RATIOTV:
dec_ref( cell->payload.ratio.dividend );
dec_ref( cell->payload.ratio.divisor );
break;
case SPECIALTV: case SPECIALTV:
dec_ref( cell->payload.special.source ); dec_ref( cell->payload.special.source );
break; break;
@ -152,24 +161,30 @@ void free_cell( struct cons_pointer pointer ) {
case SYMBOLTV: case SYMBOLTV:
dec_ref( cell->payload.string.cdr ); dec_ref( cell->payload.string.cdr );
break; break;
case VECTORPOINTTV:
/* for vector space pointers, free the actual vector-space
* object. Dangerous! */
debug_printf( DEBUG_ALLOC, L"About to free vector-space object at %ld\n",
cell->payload.vectorp.address );
//free( ( void * ) cell->payload.vectorp.address );
break;
} }
if ( !check_tag( pointer, FREETAG ) ) { if ( !check_tag( pointer, FREETAG ) ) {
if ( cell->count == 0 ) { if ( cell->count == 0 ) {
fwprintf( stderr, L"Freeing cell " ); strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH );
dump_object( stderr, pointer );
strncpy( &cell->tag.bytes[0], FREETAG, 4 );
cell->payload.free.car = NIL; cell->payload.free.car = NIL;
cell->payload.free.cdr = freelist; cell->payload.free.cdr = freelist;
freelist = pointer; freelist = pointer;
} else { } else {
fwprintf( stderr, debug_printf( DEBUG_ALLOC,
L"Attempt to free cell with %d dangling references at page %d, offset %d\n", L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n",
cell->count, pointer.page, pointer.offset ); cell->count, pointer.page, pointer.offset );
} }
} else { } else {
fwprintf( stderr, debug_printf( DEBUG_ALLOC,
L"Attempt to free cell which is already FREE at page %d, offset %d\n", L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n",
pointer.page, pointer.offset ); pointer.page, pointer.offset );
} }
} }
@ -194,19 +209,17 @@ struct cons_pointer allocate_cell( char *tag ) {
if ( strncmp( &cell->tag.bytes[0], FREETAG, TAGLENGTH ) == 0 ) { if ( strncmp( &cell->tag.bytes[0], FREETAG, TAGLENGTH ) == 0 ) {
freelist = cell->payload.free.cdr; freelist = cell->payload.free.cdr;
strncpy( &cell->tag.bytes[0], tag, 4 ); strncpy( &cell->tag.bytes[0], tag, TAGLENGTH );
cell->count = 0; cell->count = 0;
cell->payload.cons.car = NIL; cell->payload.cons.car = NIL;
cell->payload.cons.cdr = NIL; cell->payload.cons.cdr = NIL;
#ifdef DEBUG debug_printf( DEBUG_ALLOC,
fwprintf( stderr,
L"Allocated cell of type '%s' at %d, %d \n", tag, L"Allocated cell of type '%s' at %d, %d \n", tag,
result.page, result.offset ); result.page, result.offset );
#endif
} else { } else {
fwprintf( stderr, L"WARNING: Allocating non-free cell!" ); debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
} }
} }
@ -225,7 +238,7 @@ void initialise_cons_pages( ) {
make_cons_page( ); make_cons_page( );
conspageinitihasbeencalled = true; conspageinitihasbeencalled = true;
} else { } else {
fwprintf( stderr, debug_printf( DEBUG_ALLOC,
L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); L"WARNING: initialise_cons_pages() called a second or subsequent time\n" );
} }
} }

4
src/conspage.h → src/memory/conspage.h
View file

@ -19,7 +19,7 @@
* 4294967296. * 4294967296.
* *
* Note that this means the total number of addressable cons cells is * 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 * 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 * 4e9 bytes. So we're talking about a potential total of 8e100 bytes
* of addressable memory, which is only slightly more than the * 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. * belongs in this file.
*/ */
extern struct cons_pointer freelist; extern struct cons_pointer freelist;

129
src/consspaceobject.c → src/memory/consspaceobject.c
View file

@ -20,6 +20,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "print.h" #include "print.h"
#include "stack.h" #include "stack.h"
@ -54,7 +55,7 @@ void inc_ref( struct cons_pointer pointer ) {
void dec_ref( struct cons_pointer pointer ) { void dec_ref( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
if ( cell->count <= MAXREFERENCE ) { if ( cell->count > 0 ) {
cell->count--; cell->count--;
if ( cell->count == 0 ) { if ( cell->count == 0 ) {
@ -63,90 +64,6 @@ void dec_ref( struct cons_pointer pointer ) {
} }
} }
void dump_string_cell( FILE * output, wchar_t *prefix,
struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
if ( cell.payload.string.character == 0 ) {
fwprintf( output,
L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n",
prefix,
cell.payload.string.cdr.page, cell.payload.string.cdr.offset,
cell.count );
} else {
fwprintf( output,
L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n",
prefix,
( wint_t ) cell.payload.string.character,
cell.payload.string.character,
cell.payload.string.cdr.page,
cell.payload.string.cdr.offset, cell.count );
fwprintf( output, L"\t\t value: " );
print( output, pointer );
fwprintf( output, L"\n" );
}
}
/**
* dump the object at this cons_pointer to this output stream.
*/
void dump_object( FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
fwprintf( output,
L"\t%c%c%c%c (%d) at page %d, offset %d count %u\n",
cell.tag.bytes[0],
cell.tag.bytes[1],
cell.tag.bytes[2],
cell.tag.bytes[3],
cell.tag.value, pointer.page, pointer.offset, cell.count );
switch ( cell.tag.value ) {
case CONSTV:
fwprintf( output,
L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u\n",
cell.payload.cons.car.page,
cell.payload.cons.car.offset,
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset, cell.count );
break;
case EXCEPTIONTV:
fwprintf( output, L"\t\tException cell: " );
print( output, cell.payload.exception.message );
fwprintf( output, L"\n" );
for ( struct stack_frame * frame = cell.payload.exception.frame;
frame != NULL; frame = frame->previous ) {
dump_frame( output, frame );
}
break;
case FREETV:
fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n",
cell.payload.cons.cdr.page,
cell.payload.cons.cdr.offset );
break;
case INTEGERTV:
fwprintf( output,
L"\t\tInteger cell: value %ld, count %u\n",
cell.payload.integer.value, cell.count );
break;
case LAMBDATV:
fwprintf( output, L"\t\tLambda cell; args: " );
print( output, cell.payload.lambda.args );
fwprintf( output, L";\n\t\t\tbody: " );
print( output, cell.payload.lambda.body );
break;
case READTV:
fwprintf( output, L"\t\tInput stream\n" );
case REALTV:
fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n",
cell.payload.real.value, cell.count );
break;
case STRINGTV:
dump_string_cell( output, L"String", pointer );
break;
case SYMBOLTV:
dump_string_cell( output, L"Symbol", pointer );
break;
}
}
/** /**
* Construct a cons cell from this pair of pointers. * Construct a cons cell from this pair of pointers.
@ -170,20 +87,24 @@ struct cons_pointer make_cons( struct cons_pointer car,
/** /**
* Construct an exception cell. * Construct an exception cell.
* @param message should be a lisp string describing the problem, but actually any cons pointer will do; * @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 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_pointer pointer = allocate_cell( EXCEPTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer ); 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( 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( message );
inc_ref( frame_pointer );
cell->payload.exception.message = message; cell->payload.exception.message = message;
cell->payload.exception.frame = frame; cell->payload.exception.frame = frame_pointer;
return pointer; result = pointer;
return result;
} }
@ -192,7 +113,8 @@ struct cons_pointer make_exception( struct cons_pointer message,
*/ */
struct cons_pointer struct cons_pointer
make_function( struct cons_pointer src, struct cons_pointer ( *executable ) 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_pointer pointer = allocate_cell( FUNCTIONTAG );
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
@ -257,11 +179,13 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) {
cell->payload.string.character = c; cell->payload.string.character = c;
cell->payload.string.cdr.page = tail.page; cell->payload.string.cdr.page = tail.page;
/* TODO: There's a problem here. Sometimes the offsets on /* 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; cell->payload.string.cdr.offset = tail.offset;
} else { } else {
fwprintf( stderr, // TODO: should throw an exception!
L"Warning: only NIL and %s can be appended to %s\n", debug_printf( DEBUG_ALLOC,
L"Warning: only NIL and %s can be prepended to %s\n",
tag, tag ); tag, tag );
} }
@ -290,7 +214,8 @@ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) {
*/ */
struct cons_pointer struct cons_pointer
make_special( struct cons_pointer src, struct cons_pointer ( *executable ) 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_pointer pointer = allocate_cell( SPECIALTAG );
struct cons_space_object *cell = &pointer2cell( pointer ); struct cons_space_object *cell = &pointer2cell( pointer );
@ -327,26 +252,26 @@ struct cons_pointer make_write_stream( FILE * output ) {
} }
/** /**
* Return a lisp string representation of this old skool ASCII string. * Return a lisp string representation of this wide character string.
*/ */
struct cons_pointer c_string_to_lisp_string( char *string ) { struct cons_pointer c_string_to_lisp_string( wchar_t *string ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
for ( int i = strlen( string ); i > 0; i-- ) { for ( int i = wcslen( string ); i > 0; i-- ) {
result = make_string( ( wint_t ) string[i - 1], result ); result = make_string( string[i - 1], result );
} }
return 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; struct cons_pointer result = NIL;
for ( int i = strlen( symbol ); i > 0; i-- ) { for ( int i = wcslen( symbol ); i > 0; i-- ) {
result = make_symbol( ( wint_t ) symbol[i - 1], result ); result = make_symbol( symbol[i - 1], result );
} }
return result; return result;

111
src/consspaceobject.h → src/memory/consspaceobject.h
View file

@ -28,6 +28,13 @@
/** /**
* tag values, all of which must be 4 bytes. Must not collide with vector space tag values * tag values, all of which must be 4 bytes. Must not collide with vector space tag values
*/ */
/**
* A word within a bignum - arbitrary precision integer.
*/
#define BIGNUMTAG "BIGN"
#define BIGNUMTV 1313294658
/** /**
* An ordinary cons cell: 1397641027 * An ordinary cons cell: 1397641027
*/ */
@ -38,7 +45,6 @@
* An exception. * An exception.
*/ */
#define EXCEPTIONTAG "EXEP" #define EXCEPTIONTAG "EXEP"
/* TODO: this is wrong */
#define EXCEPTIONTV 1346721861 #define EXCEPTIONTV 1346721861
/** /**
@ -91,6 +97,12 @@
#define REALTAG "REAL" #define REALTAG "REAL"
#define REALTV 1279346002 #define REALTV 1279346002
/**
* A ratio.
*/
#define RATIOTAG "RTIO"
#define RATIOTV 1330205778
/** /**
* A special form - one whose arguments are not pre-evaluated but passed as a * A special form - one whose arguments are not pre-evaluated but passed as a
* s-expression. 1296453715 * s-expression. 1296453715
@ -121,12 +133,11 @@
* A pointer to an object in vector space. * A pointer to an object in vector space.
*/ */
#define VECTORPOINTTAG "VECP" #define VECTORPOINTTAG "VECP"
#define VECTORPOINTTV 1346585942
/** /**
* An open write stream. * An open write stream.
*/ */
#define WRITETAG "WRIT" #define WRITETAG "WRIT"
/* TODO: this is wrong */
#define WRITETV 1414091351 #define WRITETV 1414091351
/** /**
@ -157,6 +168,11 @@
*/ */
#define nilp(conspoint) (check_tag(conspoint,NILTAG)) #define nilp(conspoint) (check_tag(conspoint,NILTAG))
/**
* true if conspointer points to a cons cell, else false
*/
#define bignump(conspoint) (check_tag(conspoint,BIGNUMTAG))
/** /**
* true if conspointer points to a cons cell, else false * true if conspointer points to a cons cell, else false
*/ */
@ -197,6 +213,11 @@
*/ */
#define integerp(conspoint) (check_tag(conspoint,INTEGERTAG)) #define integerp(conspoint) (check_tag(conspoint,INTEGERTAG))
/**
* true if conspointer points to a rational number cell, else false
*/
#define ratiop(conspoint) (check_tag(conspoint,RATIOTAG))
/** /**
* true if conspointer points to a read stream cell, else false * true if conspointer points to a read stream cell, else false
*/ */
@ -211,7 +232,14 @@
* true if conspointer points to some sort of a number cell, * true if conspointer points to some sort of a number cell,
* else false * else false
*/ */
#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,REALTAG)) #define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG))
#define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG))
/**
* true if thr conspointer points to a vector pointer.
*/
#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTAG))
/** /**
* true if conspointer points to a write stream cell, else false. * true if conspointer points to a write stream cell, else false.
@ -235,9 +263,10 @@
* An indirect pointer to a cons cell * An indirect pointer to a cons cell
*/ */
struct cons_pointer { struct cons_pointer {
uint32_t page; /* the index of the page on which this cell /** the index of the page on which this cell resides */
* resides */ uint32_t page;
uint32_t offset; /* the index of the cell within the page */ /** the index of the cell within the page */
uint32_t offset;
}; };
/* /*
@ -250,15 +279,26 @@ struct cons_pointer {
* here to avoid circularity. TODO: refactor. * here to avoid circularity. TODO: refactor.
*/ */
struct stack_frame { struct stack_frame {
struct stack_frame *previous; /* the previous frame */ struct cons_pointer previous; /* the previous frame */
struct cons_pointer arg[args_in_frame]; struct cons_pointer arg[args_in_frame];
/* /*
* first 8 arument bindings * first 8 arument bindings
*/ */
struct cons_pointer more; /* list of any further argument bindings */ struct cons_pointer more; /* list of any further argument bindings */
struct cons_pointer function; /* the function to be called */ struct cons_pointer function; /* the function to be called */
int args;
}; };
/**
* payload of a bignum cell. Intentionally similar to an integer payload, but
* with a next pointer.
*/
struct bignum_payload {
int64_t value;
struct cons_pointer next;
};
/** /**
* payload of a cons cell. * payload of a cons cell.
*/ */
@ -273,7 +313,7 @@ struct cons_payload {
*/ */
struct exception_payload { struct exception_payload {
struct cons_pointer message; struct cons_pointer message;
struct stack_frame *frame; struct cons_pointer frame;
}; };
/** /**
@ -288,6 +328,7 @@ struct exception_payload {
struct function_payload { struct function_payload {
struct cons_pointer source; struct cons_pointer source;
struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer ( *executable ) ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ); struct cons_pointer );
}; };
@ -306,7 +347,7 @@ struct free_payload {
* optional bignum object. * optional bignum object.
*/ */
struct integer_payload { struct integer_payload {
long int value; int64_t value;
}; };
/** /**
@ -317,10 +358,19 @@ struct lambda_payload {
struct cons_pointer body; struct cons_pointer body;
}; };
/**
* payload for ratio cells. Both dividend and divisor must point to integer (or, later, bignum) cells.
*/
struct ratio_payload {
struct cons_pointer dividend;
struct cons_pointer divisor;
};
/** /**
* payload for a real number cell. Internals of this liable to change to give 128 bits * payload for a real number cell. Internals of this liable to change to give 128 bits
* precision, but I'm not sure of the detail. * precision, but I'm not sure of the detail.
*/ struct real_payload { */
struct real_payload {
long double value; long double value;
}; };
@ -332,13 +382,11 @@ struct lambda_payload {
* its argument list) and a cons pointer (representing its environment) and a * its argument list) and a cons pointer (representing its environment) and a
* stack frame (representing the previous stack frame) as arguments and returns * stack frame (representing the previous stack frame) as arguments and returns
* a cons pointer (representing its result). * 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 special_payload {
struct cons_pointer source; struct cons_pointer source;
struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer ( *executable ) ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ); struct cons_pointer );
}; };
@ -361,6 +409,9 @@ struct string_payload {
struct cons_pointer cdr; struct cons_pointer cdr;
}; };
/**
* payload of a vector pointer cell.
*/
struct vectorp_payload { struct vectorp_payload {
union { union {
char bytes[TAGLENGTH]; /* the tag (type) of the char bytes[TAGLENGTH]; /* the tag (type) of the
@ -371,9 +422,10 @@ struct vectorp_payload {
* tag. */ * tag. */
uint32_t value; /* the tag considered as a number */ uint32_t value; /* the tag considered as a number */
} tag; } tag;
uint64_t address; /* the address of the actual vector space void *address;
* object (TODO: will change when I actually /* the address of the actual vector space
* implement vector space) */ * object (TODO: will change when I actually
* implement vector space) */
}; };
/** /**
@ -418,6 +470,10 @@ struct cons_space_object {
* if tag == NILTAG; we'll treat the special cell NIL as just a cons * if tag == NILTAG; we'll treat the special cell NIL as just a cons
*/ */
struct cons_payload nil; struct cons_payload nil;
/*
* if tag == RATIOTAG
*/
struct ratio_payload ratio;
/* /*
* if tag == READTAG || tag == WRITETAG * if tag == READTAG || tag == WRITETAG
*/ */
@ -460,20 +516,11 @@ void inc_ref( struct cons_pointer pointer );
*/ */
void dec_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 make_cons( struct cons_pointer car,
struct cons_pointer cdr ); 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 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. * Construct a cell which points to an executable Lisp special form.
@ -481,6 +528,7 @@ struct cons_pointer make_exception( struct cons_pointer message,
struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer make_function( struct cons_pointer src,
struct cons_pointer ( *executable ) struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ) ); struct cons_pointer ) );
/** /**
@ -496,12 +544,13 @@ struct cons_pointer make_lambda( struct cons_pointer args,
struct cons_pointer make_nlambda( struct cons_pointer args, struct cons_pointer make_nlambda( struct cons_pointer args,
struct cons_pointer body ); struct cons_pointer body );
/** /**
* Construct a cell which points to an executable Lisp special form. * Construct a cell which points to an executable Lisp special form.
*/ */
struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer make_special( struct cons_pointer src,
struct cons_pointer ( *executable ) struct cons_pointer ( *executable )
( struct stack_frame *, ( struct stack_frame *,
struct cons_pointer,
struct cons_pointer ) ); struct cons_pointer ) );
/** /**
@ -533,11 +582,11 @@ struct cons_pointer make_write_stream( FILE * output );
/** /**
* Return a lisp string representation of this old skool ASCII string. * 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. * 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 #endif

9
src/memory/cursor.c Normal file
View file

@ -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)
*/

BIN
src/memory/cursor.h Normal file
View file

Binary file not shown.

140
src/memory/dump.c Normal file
View file

@ -0,0 +1,140 @@
/*
* dump.c
*
* Dump representations of both cons space and vector space objects.
*
*
* (c) 2018 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#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;
}
}

29
src/memory/dump.h Normal file
View file

@ -0,0 +1,29 @@
/**
* dump.h
*
* Dump representations of both cons space and vector space objects.
*
* (c) 2018 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include <stdint.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#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

298
src/memory/stack.c Normal file
View file

@ -0,0 +1,298 @@
/*
* stack.c
*
* The Lisp evaluation stack.
*
* Stack frames could be implemented in cons space; indeed, the stack
* could simply be an assoc list consed onto the front of the environment.
* But such a stack would be costly to search. The design sketched here,
* with stack frames as special objects, SHOULD be substantially more
* efficient, but does imply we need to generalise the idea of cons pages
* with freelists to a more general 'equal sized object pages', so that
* allocating/freeing stack frames can be more efficient.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdlib.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "debug.h"
#include "dump.h"
#include "lispops.h"
#include "print.h"
#include "stack.h"
#include "vectorspace.h"
void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value) {
debug_printf(DEBUG_STACK, L"Setting register %d to ", reg);
debug_print_object(value, DEBUG_STACK);
debug_println(DEBUG_STACK);
frame->arg[reg++] = value;
inc_ref(value);
if (reg > frame->args) {
frame->args = reg;
}
}
/**
* get the actual stackframe object from this `pointer`, or NULL if
* `pointer` is not a stackframe pointer.
*/
struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
struct stack_frame *result = NULL;
struct vector_space_object *vso =
pointer2cell( pointer ).payload.vectorp.address;
if ( vectorpointp( pointer ) && stackframep( vso ) ) {
result = ( struct stack_frame * ) &( vso->payload );
debug_printf( DEBUG_STACK, L"get_stack_frame: all good, returning %p\n",
result );
} else {
debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_STACK );
}
return result;
}
/**
* Make an empty stack frame, and return it.
* @param previous the current top-of-stack;
* @param env the environment in which evaluation happens.
* @return the new frame, or NULL if memory is exhausted.
*/
struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
struct cons_pointer result =
make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) );
debug_dump_object( result, DEBUG_ALLOC );
// debug_printf( DEBUG_STACK,
// L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n",
// pointer_to_vso( result )->header.size,
// &pointer_to_vso( result )->header.tag.bytes );
if ( !nilp( result ) ) {
struct stack_frame *frame = get_stack_frame( result );
/*
* TODO: later, pop a frame off a free-list of stack frames
*/
frame->previous = previous;
/*
* clearing the frame with memset would probably be slightly quicker, but
* this is clear.
*/
frame->more = NIL;
frame->function = NIL;
frame->args = 0;
for ( int i = 0; i < args_in_frame; i++ ) {
frame->arg[i] = NIL;
}
}
debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
debug_dump_object( result, DEBUG_ALLOC);
return result;
}
/**
* Allocate a new stack frame with its previous pointer set to this value,
* its arguments set up from these args, evaluated in this env.
* @param previous the current top-of-stack;
* @args the arguments to load into this frame;
* @param env the environment in which evaluation happens.
* @return the new frame, or an exception if one occurred while building it.
*/
struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
debug_print( L"Entering make_stack_frame\n", DEBUG_STACK );
struct cons_pointer result = make_empty_frame( previous );
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
previous );
} else {
struct stack_frame *frame = get_stack_frame( result );
while ( frame->args < args_in_frame && consp( args )) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
/*
* TODO: if we were running on real massively parallel hardware,
* each arg except the first should be handed off to another
* processor to be evaled in parallel; but see notes here:
* https://github.com/simon-brooke/post-scarcity/wiki/parallelism
*/
struct cons_pointer val = eval_form(frame, result, cell.payload.cons.car, env);
if ( exceptionp( val ) ) {
result = val;
break;
} else {
debug_printf( DEBUG_STACK, L"Setting argument %d to ", frame->args);
debug_print_object(cell.payload.cons.car, DEBUG_STACK);
set_reg( frame, frame->args, val );
}
args = cell.payload.cons.cdr;
}
if ( !exceptionp( result ) ) {
if ( consp( args ) ) {
/* if we still have args, eval them and stick the values on `more` */
struct cons_pointer more =
eval_forms( get_stack_frame( previous ), previous, args,
env );
frame->more = more;
inc_ref( more );
}
}
}
debug_print( L"make_stack_frame: returning\n", DEBUG_STACK );
debug_dump_object( result, DEBUG_STACK );
return result;
}
/**
* A 'special' frame is exactly like a normal stack frame except that the
* arguments are unevaluated.
* @param previous the previous stack frame;
* @param args a list of the arguments to be stored in this stack frame;
* @param env the execution environment;
* @return a new special frame.
*/
struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env ) {
debug_print( L"Entering make_special_frame\n", DEBUG_STACK );
struct cons_pointer result = make_empty_frame( previous );
if ( nilp( result ) ) {
/* i.e. out of memory */
result =
make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
previous );
} else {
struct stack_frame *frame = get_stack_frame( result );
while ( frame->args < args_in_frame && !nilp( args )) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
set_reg( frame, frame->args, cell.payload.cons.car );
args = cell.payload.cons.cdr;
}
if ( !exceptionp( result ) ) {
if ( consp( args ) ) {
frame->more = args;
inc_ref( args );
}
}
}
debug_print( L"make_special_frame: returning\n", DEBUG_STACK );
debug_dump_object( result, DEBUG_STACK );
return result;
}
/**
* Free this stack frame.
*/
void free_stack_frame( struct stack_frame *frame ) {
/*
* TODO: later, push it back on the stack-frame freelist
*/
for ( int i = 0; i < args_in_frame; i++ ) {
dec_ref( frame->arg[i] );
}
if ( !nilp( frame->more ) ) {
dec_ref( frame->more );
}
free( frame );
}
/**
* Dump a stackframe to this stream for debugging
* @param output the stream
* @param frame_pointer the pointer to the frame
*/
void dump_frame( FILE * output, struct cons_pointer frame_pointer ) {
struct stack_frame *frame = get_stack_frame( frame_pointer );
if ( frame != NULL ) {
fwprintf( output, L"Stack frame with %d arguments:\n", frame->args);
for ( int arg = 0; arg < frame->args; arg++ ) {
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
cell.tag.bytes[0],
cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
cell.count );
print( output, frame->arg[arg] );
fputws( L"\n", output );
}
if (!nilp(frame->more))
{
fputws( L"More: \t", output );
print( output, frame->more );
fputws( L"\n", output );
}
}
}
void dump_stack_trace( FILE * output, struct cons_pointer pointer ) {
if ( exceptionp( pointer ) ) {
print( output, pointer2cell( pointer ).payload.exception.message );
fputws( L"\n", output );
dump_stack_trace( output,
pointer2cell( pointer ).payload.exception.frame );
} else {
while ( vectorpointp( pointer )
&& stackframep( pointer_to_vso( pointer ) ) ) {
dump_frame( output, pointer );
pointer = get_stack_frame( pointer )->previous;
}
}
}
/**
* Fetch a pointer to the value of the local variable at this index.
*/
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int index ) {
struct cons_pointer result = NIL;
if ( index < args_in_frame ) {
result = frame->arg[index];
} else {
struct cons_pointer p = frame->more;
for ( int i = args_in_frame; i < index; i++ ) {
p = pointer2cell( p ).payload.cons.cdr;
}
result = pointer2cell( p ).payload.cons.car;
}
return result;
}

53
src/stack.h → src/memory/stack.h
View file

@ -25,38 +25,41 @@
#define __stack_h #define __stack_h
/** /**
* Make an empty stack frame, and return it. * macros for the tag of a stack frame.
* @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, #define STACKFRAMETAG "STAK"
struct cons_pointer env ); #define STACKFRAMETV 1262572627
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 * is this vector-space object a stack frame?
* @param output the stream
* @param frame the frame
*/ */
void dump_frame( FILE * output, struct stack_frame *frame ); #define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV)
/**
* set a register in a stack frame. Alwaye use this macro to do so,
• because that way we can be sure the inc_ref happens!
*/
//#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);}
void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value);
struct stack_frame *get_stack_frame( struct cons_pointer pointer );
struct cons_pointer make_empty_frame( struct cons_pointer previous );
struct cons_pointer make_stack_frame( struct cons_pointer previous,
struct cons_pointer args,
struct cons_pointer env );
void free_stack_frame( struct stack_frame *frame );
void dump_frame( FILE * output, struct cons_pointer pointer );
void dump_stack_trace( FILE * output, struct cons_pointer frame_pointer );
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n ); struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n );
/** struct cons_pointer make_special_frame( struct cons_pointer previous,
* A 'special' frame is exactly like a normal stack frame except that the
* arguments are unevaluated.
* @param previous the previous stack frame;
* @param args a list of the arguments to be stored in this stack frame;
* @param env the execution environment;
* @return a new special frame.
*/
struct stack_frame *make_special_frame( struct stack_frame *previous,
struct cons_pointer args, struct cons_pointer args,
struct cons_pointer env ); struct cons_pointer env );

97
src/memory/vectorspace.c Normal file
View file

@ -0,0 +1,97 @@
/*
* vectorspace.c
*
* Structures common to all vector space objects.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <math.h>
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "conspage.h"
#include "consspaceobject.h"
#include "debug.h"
#include "vectorspace.h"
/**
* make a cons-space object which points to the vector space object
* with this `tag` at this `address`.
* NOTE that `tag` should be the vector-space tag of the particular type of
* vector-space object, NOT `VECTORPOINTTAG`.
*/
struct cons_pointer make_vec_pointer( struct vector_space_object *address ) {
debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC );
struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG );
struct cons_space_object *cell = &pointer2cell( pointer );
debug_printf( DEBUG_ALLOC,
L"make_vec_pointer: tag written, about to set pointer address to %p\n",
address );
cell->payload.vectorp.address = address;
debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n",
cell->payload.vectorp.address );
debug_dump_object( pointer, DEBUG_ALLOC );
return pointer;
}
/**
* allocate a vector space object with this `payload_size` and `tag`,
* and return a `cons_pointer` which points to an object whigh points to it.
* NOTE that `tag` should be the vector-space tag of the particular type of
* vector-space object, NOT `VECTORPOINTTAG`.
* Returns NIL if the vector could not be allocated due to memory exhaustion.
*/
struct cons_pointer make_vso( char *tag, uint64_t payload_size ) {
debug_print( L"Entered make_vso\n", DEBUG_ALLOC );
struct cons_pointer result = NIL;
int64_t total_size = sizeof( struct vector_space_header ) + payload_size;
/* Pad size to 64 bit words. This is intended to promote access efficiancy
* on 64 bit machines but may just be voodoo coding */
uint64_t padded = ceil( ( total_size * 8.0 ) / 8.0 );
debug_print( L"make_vso: about to malloc\n", DEBUG_ALLOC );
struct vector_space_object *vso = malloc( padded );
if ( vso != NULL ) {
debug_printf( DEBUG_ALLOC,
L"make_vso: about to write tag '%s' into vso at %p\n", tag,
vso );
strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH );
result = make_vec_pointer( vso );
debug_dump_object( result, DEBUG_ALLOC );
vso->header.vecp = result;
// memcpy(vso->header.vecp, result, sizeof(struct cons_pointer));
vso->header.size = payload_size;
#ifdef DEBUG
debug_printf( DEBUG_ALLOC,
L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n",
&vso->header.tag.bytes, total_size, vso->header.size, vso,
&vso->payload );
if ( padded != total_size ) {
debug_printf( DEBUG_ALLOC, L"\t\tPadded from %d to %d\n",
total_size, padded );
}
#endif
}
#ifdef DEBUG
debug_printf( DEBUG_ALLOC, L"make_vso: all good, returning pointer to %p\n",
pointer2cell( result ).payload.vectorp.address );
#endif
return result;
}

71
src/memory/vectorspace.h Normal file
View file

@ -0,0 +1,71 @@
/**
* vectorspace.h
*
* Declarations common to all vector space objects.
*
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdbool.h>
#include <stdint.h>
#include <stdio.h>
/*
* wide characters
*/
#include <wchar.h>
#include <wctype.h>
#include "consspaceobject.h"
#ifndef __vectorspace_h
#define __vectorspace_h
/*
* part of the implementation structure of a namespace.
*/
#define HASHTAG "HASH"
#define HASHTV 0
/*
* a namespace (i.e. a binding of names to values, implemented as a hashmap)
*/
#define NAMESPACETAG "NMSP"
#define NAMESPACETV 0
/*
* a vector of cons pointers.
*/
#define VECTORTAG "VECT"
#define VECTORTV 0
#define pointer_to_vso(pointer)((vectorpointp(pointer)? (struct vector_space_object *) pointer2cell(pointer).payload.vectorp.address : (struct vector_space_object *) NULL))
#define vso_get_vecp(vso)((vso->header.vecp))
struct cons_pointer make_vso( char *tag, uint64_t payload_size );
struct vector_space_header {
union {
char bytes[TAGLENGTH]; /* the tag (type) of the
* vector-space object this cell
* points to, considered as bytes.
* NOTE that the vector space object
* should itself have the identical
* tag. */
uint32_t value; /* the tag considered as a number */
} tag;
struct cons_pointer vecp; /* back pointer to the vector pointer
* which uniquely points to this vso */
uint64_t size; /* the size of my payload, in bytes */
};
struct vector_space_object {
struct vector_space_header header;
char payload; /* we'll malloc `size` bytes for payload,
* `payload` is just the first of these.
* TODO: this is almost certainly not
* idiomatic C. */
};
#endif

4
src/equal.c → src/ops/equal.c
View file

@ -80,8 +80,8 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
&& ( equal( cell_a->payload.string.cdr, && ( equal( cell_a->payload.string.cdr,
cell_b->payload.string.cdr ) cell_b->payload.string.cdr )
|| ( end_of_string( cell_a->payload.string.cdr ) || ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload.string. && end_of_string( cell_b->payload.
cdr ) ) ); string.cdr ) ) );
break; break;
case INTEGERTV: case INTEGERTV:
result = result =

0
src/equal.h → src/ops/equal.h
View file

37
src/intern.c → src/ops/intern.c
View file

@ -21,6 +21,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "equal.h" #include "equal.h"
#include "lispops.h" #include "lispops.h"
#include "print.h" #include "print.h"
@ -56,22 +57,22 @@ internedp( struct cons_pointer key, struct cons_pointer store ) {
struct cons_space_object entry = struct cons_space_object entry =
pointer2cell( pointer2cell( next ).payload.cons.car ); pointer2cell( pointer2cell( next ).payload.cons.car );
fputws( L"Internedp: checking whether `", stderr ); debug_print( L"Internedp: checking whether `", DEBUG_ALLOC );
print( stderr, key ); debug_print_object( key, DEBUG_ALLOC );
fputws( L"` equals `", stderr ); debug_print( L"` equals `", DEBUG_ALLOC );
print( stderr, entry.payload.cons.car ); debug_print_object( entry.payload.cons.car, DEBUG_ALLOC );
fputws( L"`\n", stderr ); debug_print( L"`\n", DEBUG_ALLOC );
if ( equal( key, entry.payload.cons.car ) ) { if ( equal( key, entry.payload.cons.car ) ) {
result = entry.payload.cons.car; result = entry.payload.cons.car;
} }
} }
} else { } else {
fputws( L"`", stderr ); debug_print( L"`", DEBUG_ALLOC );
print( stderr, key ); debug_print_object( key, DEBUG_ALLOC );
fputws( L"` is a ", stderr ); debug_print( L"` is a ", DEBUG_ALLOC );
print( stderr, c_type( key ) ); debug_print_object( c_type( key ), DEBUG_ALLOC );
fputws( L", not a SYMB", stderr ); debug_print( L", not a SYMB", DEBUG_ALLOC );
} }
return result; return result;
@ -110,6 +111,12 @@ struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer struct cons_pointer
bind( struct cons_pointer key, struct cons_pointer value, bind( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) { 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 ); return make_cons( make_cons( key, value ), store );
} }
@ -120,7 +127,17 @@ bind( struct cons_pointer key, struct cons_pointer value,
*/ */
struct cons_pointer struct cons_pointer
deep_bind( struct cons_pointer key, struct cons_pointer value ) { 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 ); oblist = bind( key, value, oblist );
debug_print( L"Leaving deep_bind\n", DEBUG_ALLOC );
return oblist; return oblist;
} }

0
src/intern.h → src/ops/intern.h
View file

421
src/lispops.c → src/ops/lispops.c
View file

@ -26,6 +26,8 @@
#include "consspaceobject.h" #include "consspaceobject.h"
#include "conspage.h" #include "conspage.h"
#include "debug.h"
#include "dump.h"
#include "equal.h" #include "equal.h"
#include "integer.h" #include "integer.h"
#include "intern.h" #include "intern.h"
@ -80,23 +82,27 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) {
* @return the result of evaluating the form. * @return the result of evaluating the form.
*/ */
struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer parent_pointer,
struct cons_pointer form, struct cons_pointer form,
struct cons_pointer env ) { struct cons_pointer env ) {
fputws( L"eval_form: ", stderr ); debug_print( L"eval_form: ", DEBUG_EVAL );
print( stderr, form ); debug_dump_object( form, DEBUG_EVAL );
fputws( L"\n", stderr );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct stack_frame *next = make_empty_frame( parent, env ); struct cons_pointer next_pointer = make_empty_frame( parent_pointer );
next->arg[0] = form; inc_ref( next_pointer );
inc_ref( next->arg[0] );
result = lisp_eval( next, env ); struct stack_frame *next = get_stack_frame( next_pointer );
set_reg( next, 0, form );
next->args = 1;
result = lisp_eval( next, next_pointer, env );
if ( !exceptionp( result ) ) { if ( !exceptionp( result ) ) {
/* if we're returning an exception, we should NOT free the /* if we're returning an exception, we should NOT free the
* stack frame. Corollary is, when we free an exception, we * stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */ * should free all the frames it's holding on to. */
free_stack_frame( next ); dec_ref( next_pointer );
} }
return result; return result;
@ -108,11 +114,14 @@ struct cons_pointer eval_form( struct stack_frame *parent,
* `list` is not in fact a list, return nil. * `list` is not in fact a list, return nil.
*/ */
struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer list, struct cons_pointer list,
struct cons_pointer env ) { struct cons_pointer env ) {
/* TODO: refactor. This runs up the C stack. */
return consp( list ) ? return consp( list ) ?
make_cons( eval_form( frame, c_car( list ), env ), make_cons( eval_form( frame, frame_pointer, c_car( list ), env ),
eval_forms( frame, c_cdr( list ), env ) ) : NIL; eval_forms( frame, frame_pointer, c_cdr( list ),
env ) ) : NIL;
} }
/** /**
@ -121,7 +130,8 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
* (oblist) * (oblist)
*/ */
struct cons_pointer 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; return oblist;
} }
@ -130,8 +140,7 @@ lisp_oblist( struct stack_frame *frame, struct cons_pointer env ) {
* used to construct the body for `lambda` and `nlambda` expressions. * used to construct the body for `lambda` and `nlambda` expressions.
*/ */
struct cons_pointer compose_body( struct stack_frame *frame ) { struct cons_pointer compose_body( struct stack_frame *frame ) {
struct cons_pointer body = struct cons_pointer body = frame->more;
!nilp( frame->arg[args_in_frame - 1] ) ? frame->more : NIL;
for ( int i = args_in_frame - 1; i > 0; i-- ) { for ( int i = args_in_frame - 1; i > 0; i-- ) {
if ( !nilp( body ) ) { if ( !nilp( body ) ) {
@ -141,9 +150,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
} }
} }
fputws( L"compose_body returning ", stderr ); debug_print( L"compose_body returning ", DEBUG_LAMBDA );
print( stderr, body ); debug_dump_object( body, DEBUG_LAMBDA );
fputws( L"\n", stderr );
return body; return body;
} }
@ -155,7 +163,8 @@ struct cons_pointer compose_body( struct stack_frame *frame ) {
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer 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 ) ); return make_lambda( frame->arg[0], compose_body( frame ) );
} }
@ -166,16 +175,16 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer env ) {
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer 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 ) ); return make_nlambda( frame->arg[0], compose_body( frame ) );
} }
void log_binding( struct cons_pointer name, struct cons_pointer val ) { void log_binding( struct cons_pointer name, struct cons_pointer val ) {
print( stderr, c_string_to_lisp_string( "\n\tBinding " ) ); debug_print( L"\n\tBinding ", DEBUG_ALLOC );
print( stderr, name ); debug_dump_object( name, DEBUG_ALLOC );
print( stderr, c_string_to_lisp_string( " to " ) ); debug_print( L" to ", DEBUG_ALLOC );
print( stderr, val ); debug_dump_object( val, DEBUG_ALLOC );
fputws( L"\"\n", stderr );
} }
/** /**
@ -183,9 +192,9 @@ void log_binding( struct cons_pointer name, struct cons_pointer val ) {
*/ */
struct cons_pointer struct cons_pointer
eval_lambda( struct cons_space_object cell, struct stack_frame *frame, 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; 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 new_env = env;
struct cons_pointer names = cell.payload.lambda.args; 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 ( consp( names ) ) {
/* if `names` is a list, bind successive items from that list /* if `names` is a list, bind successive items from that list
* to values of arguments */ * 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 name = c_car( names );
struct cons_pointer val = frame->arg[i]; 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 ); names = c_cdr( names );
} }
/* TODO: if there's more than `args_in_frame` arguments, bind those too. */
} else if ( symbolp( names ) ) { } else if ( symbolp( names ) ) {
/* if `names` is a symbol, rather than a list of symbols, /* if `names` is a symbol, rather than a list of symbols,
* then bind a list of the values of args to that symbol. */ * 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; struct cons_pointer vals = frame->more;
for ( int i = args_in_frame - 1; i >= 0; i-- ) { 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 */ if ( nilp( val ) && nilp( vals ) ) { /* nothing */
} else { } else {
@ -223,8 +235,10 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
while ( !nilp( body ) ) { while ( !nilp( body ) ) {
struct cons_pointer sexpr = c_car( body ); struct cons_pointer sexpr = c_car( body );
body = c_cdr( 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; return result;
@ -239,20 +253,17 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
* @return the result of evaluating the function with its arguments. * @return the result of evaluating the function with its arguments.
*/ */
struct cons_pointer struct cons_pointer
c_apply( struct stack_frame *frame, struct cons_pointer env ) { c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer result = NIL; struct cons_pointer env ) {
struct stack_frame *fn_frame = make_empty_frame( frame, env ); debug_print(L"Entering c_apply\n", DEBUG_EVAL);
fn_frame->arg[0] = c_car( frame->arg[0] ); struct cons_pointer result = NIL;
inc_ref( fn_frame->arg[0] );
struct cons_pointer fn_pointer = lisp_eval( fn_frame, env );
if ( !exceptionp( result ) ) { struct cons_pointer fn_pointer =
/* if we're returning an exception, we should NOT free the eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env );
* 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 );
}
if ( exceptionp( fn_pointer ) ) {
result = fn_pointer;
} else {
struct cons_space_object fn_cell = pointer2cell( fn_pointer ); struct cons_space_object fn_cell = pointer2cell( fn_pointer );
struct cons_pointer args = c_cdr( frame->arg[0] ); struct cons_pointer args = c_cdr( frame->arg[0] );
@ -264,80 +275,92 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
case FUNCTIONTV: case FUNCTIONTV:
{ {
struct cons_pointer exep = NIL; struct cons_pointer exep = NIL;
struct stack_frame *next = struct cons_pointer next_pointer =
make_stack_frame( frame, args, env, &exep ); make_stack_frame( frame_pointer, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env ); inc_ref( next_pointer );
if ( exceptionp( exep ) ) { if ( exceptionp( next_pointer ) ) {
/* if we're returning an exception, we should NOT free the result = next_pointer;
* stack frame. Corollary is, when we free an exception, we
* should free all the frames it's holding on to. */
result = exep;
} else { } 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; break;
case LAMBDATV: case LAMBDATV:
{ {
struct cons_pointer exep = NIL; struct cons_pointer exep = NIL;
struct stack_frame *next = struct cons_pointer next_pointer =
make_stack_frame( frame, args, env, &exep ); make_stack_frame( frame_pointer, args, env );
fputws( L"Stack frame for lambda\n", stderr ); inc_ref( next_pointer );
dump_frame( stderr, next ); if ( exceptionp( next_pointer ) ) {
result = eval_lambda( fn_cell, next, env ); result = next_pointer;
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;
} else { } 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; break;
case NLAMBDATV: case NLAMBDATV:
{ {
struct stack_frame *next = struct cons_pointer next_pointer =
make_special_frame( frame, args, env ); make_special_frame( frame_pointer, args, env );
fputws( L"Stack frame for nlambda\n", stderr ); inc_ref( next_pointer );
dump_frame( stderr, next ); if ( exceptionp( next_pointer ) ) {
result = eval_lambda( fn_cell, next, env ); result = next_pointer;
if ( !exceptionp( result ) ) { } else {
/* if we're returning an exception, we should NOT free the struct stack_frame *next =
* stack frame. Corollary is, when we free an exception, we get_stack_frame( next_pointer );
* should free all the frames it's holding on to. */ result = eval_lambda( fn_cell, next, next_pointer, env );
free_stack_frame( next ); dec_ref( next_pointer );
} }
} }
break; break;
case SPECIALTV: case SPECIALTV:
{ {
struct stack_frame *next = struct cons_pointer next_pointer =
make_special_frame( frame, args, env ); make_special_frame( frame_pointer, args, env );
result = ( *fn_cell.payload.special.executable ) ( next, env ); inc_ref( next_pointer );
if ( !exceptionp( result ) ) { if ( exceptionp( next_pointer ) ) {
/* if we're returning an exception, we should NOT free the result = next_pointer;
* stack frame. Corollary is, when we free an exception, we } else {
* should free all the frames it's holding on to. */ result =
free_stack_frame( next ); ( *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; break;
default: default:
{ {
char *buffer = malloc( 1024 ); int bs = sizeof(wchar_t) * 1024;
memset( buffer, '\0', 1024 ); wchar_t *buffer = malloc( bs );
sprintf( buffer, memset( buffer, '\0', bs );
"Unexpected cell with tag %d (%c%c%c%c) in function position", swprintf( buffer, bs,
fn_cell.tag.value, fn_cell.tag.bytes[0], L"Unexpected cell with tag %d (%4.4s) in function position",
fn_cell.tag.bytes[1], fn_cell.tag.bytes[2], fn_cell.tag.value, &fn_cell.tag.bytes[0] );
fn_cell.tag.bytes[3] );
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( buffer ); c_string_to_lisp_string( buffer );
free( 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; return result;
} }
@ -349,13 +372,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer env ) {
* @return As a Lisp string, the tag of the object which is at that pointer. * @return As a Lisp string, the tag of the object which is at that pointer.
*/ */
struct cons_pointer c_type( struct cons_pointer pointer ) { struct cons_pointer c_type( struct cons_pointer pointer ) {
char *buffer = malloc( TAGLENGTH + 1 ); struct cons_pointer result = NIL;
memset( buffer, 0, TAGLENGTH + 1 );
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
strncpy( buffer, cell.tag.bytes, TAGLENGTH );
struct cons_pointer result = c_string_to_lisp_string( buffer ); for (int i = TAGLENGTH; i >= 0; i--)
free( buffer ); {
result = make_string((wchar_t)cell.tag.bytes[i], result);
}
return result; return result;
} }
@ -375,17 +398,18 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
* If a special form, passes the cdr of s_expr to the special form as argument. * If a special form, passes the cdr of s_expr to the special form as argument.
*/ */
struct cons_pointer 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_pointer result = frame->arg[0];
struct cons_space_object cell = pointer2cell( frame->arg[0] ); struct cons_space_object cell = pointer2cell( frame->arg[0] );
fputws( L"Eval: ", stderr );
dump_frame( stderr, frame );
switch ( cell.tag.value ) { switch ( cell.tag.value ) {
case CONSTV: case CONSTV:
{ {
result = c_apply( frame, env ); result = c_apply( frame, frame_pointer, env );
} }
break; break;
@ -396,9 +420,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
if ( nilp( canonical ) ) { if ( nilp( canonical ) ) {
struct cons_pointer message = struct cons_pointer message =
make_cons( c_string_to_lisp_string 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] ); frame->arg[0] );
result = lisp_throw( message, frame ); result = throw_exception( message, frame_pointer );
} else { } else {
result = c_assoc( canonical, env ); result = c_assoc( canonical, env );
inc_ref( result ); inc_ref( result );
@ -418,9 +442,8 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
break; break;
} }
fputws( L"Eval returning ", stderr ); debug_print( L"Eval returning ", DEBUG_EVAL );
print( stderr, result ); debug_dump_object( result, DEBUG_EVAL );
fputws( L"\n", stderr );
return result; return result;
} }
@ -434,19 +457,19 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer env ) {
* the second argument * the second argument
*/ */
struct cons_pointer struct cons_pointer
lisp_apply( struct stack_frame *frame, struct cons_pointer env ) { lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
fputws( L"Apply: ", stderr ); struct cons_pointer env ) {
dump_frame( stderr, frame ); #ifdef DEBUG
debug_print( L"Apply: ", DEBUG_EVAL );
dump_frame( stderr, frame_pointer );
#endif
set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) );
set_reg( frame, 1, NIL );
frame->arg[0] = make_cons( frame->arg[0], frame->arg[1] ); struct cons_pointer result = c_apply( frame, frame_pointer, env );
inc_ref( frame->arg[0] );
frame->arg[1] = NIL;
struct cons_pointer result = c_apply( frame, env ); debug_print( L"Apply returning ", DEBUG_EVAL );
debug_dump_object( result, DEBUG_EVAL );
fputws( L"Apply returning ", stderr );
print( stderr, result );
fputws( L"\n", stderr );
return result; return result;
} }
@ -460,7 +483,8 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer env ) {
* this isn't at this stage checked) unevaluated. * this isn't at this stage checked) unevaluated.
*/ */
struct cons_pointer 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]; return frame->arg[0];
} }
@ -475,7 +499,8 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer env ) {
* the namespace in so doing. `namespace` defaults to the value of `oblist`. * the namespace in so doing. `namespace` defaults to the value of `oblist`.
*/ */
struct cons_pointer 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 result = NIL;
struct cons_pointer namespace = struct cons_pointer namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2]; nilp( frame->arg[2] ) ? oblist : frame->arg[2];
@ -487,8 +512,9 @@ lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
result = result =
make_exception( make_cons make_exception( make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ), ( L"The first argument to `set` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), frame ); make_cons( frame->arg[0], NIL ) ),
frame_pointer );
} }
return result; return result;
@ -505,21 +531,24 @@ lisp_set( struct stack_frame *frame, struct cons_pointer env ) {
* the namespace in so doing. `namespace` defaults to the value of `oblist`. * the namespace in so doing. `namespace` defaults to the value of `oblist`.
*/ */
struct cons_pointer 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 result = NIL;
struct cons_pointer namespace = struct cons_pointer namespace =
nilp( frame->arg[2] ) ? oblist : frame->arg[2]; nilp( frame->arg[2] ) ? oblist : frame->arg[2];
if ( symbolp( frame->arg[0] ) ) { 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 ); deep_bind( frame->arg[0], val );
result = val; result = val;
} else { } else {
result = result =
make_exception( make_cons make_exception( make_cons
( c_string_to_lisp_string ( c_string_to_lisp_string
( "The first argument to `set!` is not a symbol: " ), ( L"The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ), frame ); make_cons( frame->arg[0], NIL ) ),
frame_pointer );
} }
return result; return result;
@ -534,7 +563,8 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env ) {
* otherwise returns a new cons cell. * otherwise returns a new cons cell.
*/ */
struct cons_pointer 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 car = frame->arg[0];
struct cons_pointer cdr = frame->arg[1]; struct cons_pointer cdr = frame->arg[1];
struct cons_pointer result; struct cons_pointer result;
@ -558,7 +588,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer env ) {
* strings, and TODO read streams and other things which can be considered as sequences. * strings, and TODO read streams and other things which can be considered as sequences.
*/ */
struct cons_pointer 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; struct cons_pointer result = NIL;
if ( consp( frame->arg[0] ) ) { if ( consp( frame->arg[0] ) ) {
@ -569,8 +600,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
result = make_string( cell.payload.string.character, NIL ); result = make_string( cell.payload.string.character, NIL );
} else { } else {
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CAR of non sequence" ); c_string_to_lisp_string( L"Attempt to take CAR of non sequence" );
result = lisp_throw( message, frame ); result = throw_exception( message, frame_pointer );
} }
return result; return result;
@ -582,7 +613,8 @@ lisp_car( struct stack_frame *frame, struct cons_pointer env ) {
* strings, and TODO read streams and other things which can be considered as sequences. * strings, and TODO read streams and other things which can be considered as sequences.
*/ */
struct cons_pointer 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; struct cons_pointer result = NIL;
if ( consp( frame->arg[0] ) ) { if ( consp( frame->arg[0] ) ) {
@ -593,8 +625,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
result = cell.payload.string.cdr; result = cell.payload.string.cdr;
} else { } else {
struct cons_pointer message = struct cons_pointer message =
c_string_to_lisp_string( "Attempt to take CDR of non sequence" ); c_string_to_lisp_string( L"Attempt to take CDR of non sequence" );
result = lisp_throw( message, frame ); result = throw_exception( message, frame_pointer );
} }
return result; return result;
@ -605,7 +637,8 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer env ) {
* Returns the value associated with key in store, or NIL if not found. * Returns the value associated with key in store, or NIL if not found.
*/ */
struct cons_pointer 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] ); return c_assoc( frame->arg[0], frame->arg[1] );
} }
@ -614,6 +647,7 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer env ) {
* Returns T if a and b are pointers to the same object, else NIL * 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 lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) { struct cons_pointer env ) {
return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
} }
@ -623,7 +657,8 @@ struct cons_pointer lisp_eq( struct stack_frame *frame,
* Returns T if a and b are pointers to structurally identical objects, else NIL * Returns T if a and b are pointers to structurally identical objects, else NIL
*/ */
struct cons_pointer 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; return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
} }
@ -634,14 +669,58 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer env ) {
* is a read stream, then read from that stream, else stdin. * is a read stream, then read from that stream, else stdin.
*/ */
struct cons_pointer 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; FILE *input = stdin;
if ( readp( frame->arg[0] ) ) { if ( readp( frame->arg[0] ) ) {
input = pointer2cell( frame->arg[0] ).payload.stream.stream; input = pointer2cell( frame->arg[0] ).payload.stream.stream;
} }
return read( frame, input ); struct cons_pointer result = read( frame, frame_pointer, input );
debug_print( L"lisp_read returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result;
}
/**
* reverse a sequence.
*/
struct cons_pointer c_reverse( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) {
struct cons_space_object o = pointer2cell( p );
switch ( o.tag.value ) {
case CONSTV:
result = make_cons( o.payload.cons.car, result );
break;
case STRINGTV:
result = make_string( o.payload.string.character, result );
break;
case SYMBOLTV:
result = make_symbol( o.payload.string.character, result );
break;
}
}
return result;
}
/**
* (reverse sequence)
* Return a sequence like this sequence but with the members in the reverse order.
*/
struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return c_reverse( frame->arg[0] );
} }
@ -652,16 +731,26 @@ lisp_read( struct stack_frame *frame, struct cons_pointer env ) {
* is a write stream, then print to that stream, else stdout. * is a write stream, then print to that stream, else stdout.
*/ */
struct cons_pointer 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; FILE *output = stdout;
if ( writep( frame->arg[1] ) ) { 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; output = pointer2cell( frame->arg[1] ).payload.stream.stream;
} }
debug_print( L"lisp_print: about to print\n", DEBUG_IO );
debug_dump_object( frame->arg[0], DEBUG_IO );
print( output, frame->arg[0] ); result = print( output, frame->arg[0] );
return NIL; debug_print( L"lisp_print returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result;
} }
@ -672,7 +761,8 @@ lisp_print( struct stack_frame *frame, struct cons_pointer env ) {
* @return As a Lisp string, the tag of the object which is the argument. * @return As a Lisp string, the tag of the object which is the argument.
*/ */
struct cons_pointer 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] ); return c_type( frame->arg[0] );
} }
@ -690,16 +780,17 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env ) {
* argument. * argument.
*/ */
struct cons_pointer 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 remaining = frame->more;
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { 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 ) ) { 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 ); remaining = c_cdr( remaining );
} }
@ -717,22 +808,26 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env ) {
* @return the value of the last form of the first successful clause. * @return the value of the last form of the first successful clause.
*/ */
struct cons_pointer 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; struct cons_pointer result = NIL;
bool done = false; bool done = false;
for ( int i = 0; i < args_in_frame && !done; i++ ) { for ( int i = 0; i < args_in_frame && !done; i++ ) {
struct cons_pointer clause_pointer = frame->arg[i]; struct cons_pointer clause_pointer = frame->arg[i];
fputws( L"Cond clause: ", stderr ); debug_print( L"Cond clause: ", DEBUG_EVAL );
print( stderr, clause_pointer ); debug_dump_object( clause_pointer, DEBUG_EVAL );
if ( consp( clause_pointer ) ) { if ( consp( clause_pointer ) ) {
struct cons_space_object cell = pointer2cell( 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 ) ) { if ( !nilp( result ) ) {
struct cons_pointer vals = 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 ) ) { while ( consp( vals ) ) {
result = c_car( vals ); result = c_car( vals );
@ -744,9 +839,9 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
} else if ( nilp( clause_pointer ) ) { } else if ( nilp( clause_pointer ) ) {
done = true; done = true;
} else { } else {
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "Arguments to `cond` must be lists" ), ( L"Arguments to `cond` must be lists" ),
frame ); frame_pointer );
} }
} }
/* TODO: if there are more than 8 clauses we need to continue into the /* TODO: if there are more than 8 clauses we need to continue into the
@ -756,17 +851,20 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer env ) {
} }
/** /**
* TODO: make this do something sensible somehow. * Throw an exception.
* This requires that a frame be a heap-space object with a cons-space * `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 * object pointing to it. Then this should become a normal lisp function
* which expects a normally bound frame and environment, such that * which expects a normally bound frame and environment, such that
* frame->arg[0] is the message, and frame->arg[1] is the cons-space * frame->arg[0] is the message, and frame->arg[1] is the cons-space
* pointer to the frame in which the exception occurred. * pointer to the frame in which the exception occurred.
*/ */
struct cons_pointer struct cons_pointer
lisp_throw( struct cons_pointer message, struct stack_frame *frame ) { throw_exception( struct cons_pointer message,
fwprintf( stderr, L"\nERROR: " ); struct cons_pointer frame_pointer ) {
print( stderr, message ); debug_print( L"\nERROR: ", DEBUG_EVAL );
debug_dump_object( message, DEBUG_EVAL );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( message ); struct cons_space_object cell = pointer2cell( message );
@ -774,8 +872,25 @@ lisp_throw( struct cons_pointer message, struct stack_frame *frame ) {
if ( cell.tag.value == EXCEPTIONTV ) { if ( cell.tag.value == EXCEPTIONTV ) {
result = message; result = message;
} else { } else {
result = make_exception( message, frame ); result = make_exception( message, frame_pointer );
} }
return result; return result;
} }
/**
* (exception <message>)
*
* 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 );
}

58
src/lispops.h → src/ops/lispops.h
View file

@ -40,6 +40,7 @@ struct cons_pointer c_car( struct cons_pointer arg );
*/ */
struct cons_pointer c_cdr( struct cons_pointer arg ); struct cons_pointer c_cdr( struct cons_pointer arg );
struct cons_pointer c_reverse( struct cons_pointer arg );
/** /**
* Useful building block; evaluate this single form in the context of this * Useful building block; evaluate this single form in the context of this
@ -50,6 +51,7 @@ struct cons_pointer c_cdr( struct cons_pointer arg );
* @return the result of evaluating the form. * @return the result of evaluating the form.
*/ */
struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer eval_form( struct stack_frame *parent,
struct cons_pointer parent_pointer,
struct cons_pointer form, struct cons_pointer form,
struct cons_pointer env ); struct cons_pointer env );
@ -59,6 +61,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
* `list` is not in fact a list, return nil. * `list` is not in fact a list, return nil.
*/ */
struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer eval_forms( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer list, struct cons_pointer list,
struct cons_pointer env ); struct cons_pointer env );
@ -67,18 +70,23 @@ struct cons_pointer eval_forms( struct stack_frame *frame,
* special forms * special forms
*/ */
struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer lisp_eval( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer lisp_apply( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer 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 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 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. * Construct an interpretable function.
@ -88,6 +96,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer env );
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer lisp_lambda( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/** /**
@ -97,30 +106,43 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame,
* @param env the environment in which it is to be intepreted. * @param env the environment in which it is to be intepreted.
*/ */
struct cons_pointer 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 lisp_quote( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
/* /*
* functions * functions
*/ */
struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer lisp_cons( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer lisp_car( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer lisp_cdr( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_assoc( struct stack_frame *frame, struct cons_pointer lisp_assoc( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_equal( struct stack_frame *frame, 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 env );
struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ); struct cons_pointer env );
struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer env ); struct cons_pointer frame_pointer,
struct cons_pointer env );
/** /**
* Function: Get the Lisp type of the single argument. * Function: Get the Lisp type of the single argument.
* @param frame My stack frame. * @param frame My stack frame.
@ -128,7 +150,8 @@ struct cons_pointer lisp_print( struct stack_frame *frame,
* @return As a Lisp string, the tag of the object which is the argument. * @return As a Lisp string, the tag of the object which is the argument.
*/ */
struct cons_pointer struct cons_pointer
lisp_type( struct stack_frame *frame, struct cons_pointer env ); lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/** /**
@ -142,7 +165,8 @@ lisp_type( struct stack_frame *frame, struct cons_pointer env );
* argument. * argument.
*/ */
struct cons_pointer 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 * Special form: conditional. Each arg is expected to be a list; if the first
@ -154,10 +178,18 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer env );
* @return the value of the last form of the first successful clause. * @return the value of the last form of the first successful clause.
*/ */
struct cons_pointer 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 cons_pointer throw_exception( struct cons_pointer message,
struct stack_frame *frame ); struct cons_pointer frame_pointer );
struct cons_pointer
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );

29
src/print.c → src/ops/print.c
View file

@ -20,6 +20,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "integer.h" #include "integer.h"
#include "stack.h"
#include "print.h" #include "print.h"
/** /**
@ -36,7 +37,7 @@ int print_use_colours = 0;
void print_string_contents( FILE * output, struct cons_pointer pointer ) { void print_string_contents( FILE * output, struct cons_pointer pointer ) {
while ( stringp( pointer ) || symbolp( pointer ) ) { while ( stringp( pointer ) || symbolp( pointer ) ) {
struct cons_space_object *cell = &pointer2cell( 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' ) { if ( c != '\0' ) {
fputwc( c, output ); fputwc( c, output );
@ -103,7 +104,7 @@ void print_list( FILE * output, struct cons_pointer pointer ) {
* Print the cons-space object indicated by `pointer` to the stream indicated * Print the cons-space object indicated by `pointer` to the stream indicated
* by `output`. * by `output`.
*/ */
void print( FILE * output, struct cons_pointer pointer ) { struct cons_pointer print( FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer ); struct cons_space_object cell = pointer2cell( pointer );
char *buffer; char *buffer;
@ -118,7 +119,7 @@ void print( FILE * output, struct cons_pointer pointer ) {
case EXCEPTIONTV: case EXCEPTIONTV:
fwprintf( output, L"\n%sException: ", fwprintf( output, L"\n%sException: ",
print_use_colours ? "\x1B[31m" : "" ); print_use_colours ? "\x1B[31m" : "" );
print_string_contents( output, cell.payload.exception.message ); dump_stack_trace( output, pointer );
break; break;
case FUNCTIONTV: case FUNCTIONTV:
fwprintf( output, L"(Function)" ); fwprintf( output, L"(Function)" );
@ -130,19 +131,24 @@ void print( FILE * output, struct cons_pointer pointer ) {
fwprintf( output, L"%ld%", cell.payload.integer.value ); fwprintf( output, L"%ld%", cell.payload.integer.value );
break; break;
case LAMBDATV: 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, make_cons( cell.payload.lambda.args,
cell.payload. cell.payload.lambda.
lambda.body ) ) ); body ) ) );
break; break;
case NILTV: case NILTV:
fwprintf( output, L"nil" ); fwprintf( output, L"nil" );
break; break;
case NLAMBDATV: 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, make_cons( cell.payload.lambda.args,
cell.payload. cell.payload.lambda.
lambda.body ) ) ); body ) ) );
break;
case RATIOTV:
print( output, cell.payload.ratio.dividend );
fputws( L"/", output );
print( output, cell.payload.ratio.divisor );
break; break;
case READTV: case READTV:
fwprintf( output, L"(Input stream)" ); fwprintf( output, L"(Input stream)" );
@ -184,6 +190,9 @@ void print( FILE * output, struct cons_pointer pointer ) {
case TRUETV: case TRUETV:
fwprintf( output, L"t" ); fwprintf( output, L"t" );
break; break;
case WRITETV:
fwprintf( output, L"(Output stream)" );
break;
default: default:
fwprintf( stderr, fwprintf( stderr,
L"%sError: Unrecognised tag value %d (%c%c%c%c)\n", L"%sError: Unrecognised tag value %d (%c%c%c%c)\n",
@ -196,4 +205,6 @@ void print( FILE * output, struct cons_pointer pointer ) {
if ( print_use_colours ) { if ( print_use_colours ) {
fputws( L"\x1B[39m", output ); fputws( L"\x1B[39m", output );
} }
return pointer;
} }

2
src/print.h → src/ops/print.h
View file

@ -14,7 +14,7 @@
#ifndef __print_h #ifndef __print_h
#define __print_h #define __print_h
void print( FILE * output, struct cons_pointer pointer ); struct cons_pointer print( FILE * output, struct cons_pointer pointer );
extern int print_use_colours; extern int print_use_colours;
#endif #endif

157
src/read.c → src/ops/read.c
View file

@ -18,12 +18,16 @@
#include <wctype.h> #include <wctype.h>
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "dump.h"
#include "integer.h" #include "integer.h"
#include "intern.h" #include "intern.h"
#include "lispops.h" #include "lispops.h"
#include "print.h" #include "print.h"
#include "ratio.h"
#include "read.h" #include "read.h"
#include "real.h" #include "real.h"
#include "vectorspace.h"
/* /*
* for the time being things which may be read are: strings numbers - either * for the time being things which may be read are: strings numbers - either
@ -31,8 +35,12 @@
* atoms because I don't yet know what an atom is or how it's stored. * atoms because I don't yet know what an atom is or how it's stored.
*/ */
struct cons_pointer read_number( FILE * input, wint_t initial ); struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer read_list( struct stack_frame *frame, FILE * input, 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 ); wint_t initial );
struct cons_pointer read_string( 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 ); struct cons_pointer read_symbol( FILE * input, wint_t initial );
@ -41,7 +49,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial );
* quote reader macro in C (!) * quote reader macro in C (!)
*/ */
struct cons_pointer c_quote( struct cons_pointer arg ) { 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 ) ); make_cons( arg, NIL ) );
} }
@ -50,8 +58,10 @@ struct cons_pointer c_quote( struct cons_pointer arg ) {
* treating this initial character as the first character of the object * treating this initial character as the first character of the object
* representation. * representation.
*/ */
struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input, struct cons_pointer read_continuation( struct stack_frame *frame,
wint_t initial ) { struct cons_pointer frame_pointer,
FILE * input, wint_t initial ) {
debug_print( L"entering read_continuation\n", DEBUG_IO );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
wint_t c; wint_t c;
@ -61,8 +71,8 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
if ( feof( input ) ) { if ( feof( input ) ) {
result = result =
make_exception( c_string_to_lisp_string throw_exception( c_string_to_lisp_string
( "End of file while reading" ), frame ); ( L"End of file while reading" ), frame_pointer );
} else { } else {
switch ( c ) { switch ( c ) {
case ';': case ';':
@ -70,31 +80,49 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
/* skip all characters from semi-colon to the end of the line */ /* skip all characters from semi-colon to the end of the line */
break; break;
case EOF: case EOF:
result = lisp_throw( c_string_to_lisp_string result = throw_exception( c_string_to_lisp_string
( "End of input while reading" ), frame ); ( L"End of input while reading" ),
frame_pointer );
break; break;
case '\'': case '\'':
result = result =
c_quote( read_continuation c_quote( read_continuation
( frame, input, fgetwc( input ) ) ); ( frame, frame_pointer, input,
fgetwc( input ) ) );
break; break;
case '(': case '(':
result = read_list( frame, input, fgetwc( input ) ); result =
read_list( frame, frame_pointer, input, fgetwc( input ) );
break; break;
case '"': case '"':
result = read_string( input, fgetwc( input ) ); result = read_string( input, fgetwc( input ) );
break; break;
case '-':{
wint_t next = fgetwc( input );
ungetwc( next, input );
if ( iswdigit( next ) ) {
result =
read_number( frame, frame_pointer, input, c,
false );
} else {
result = read_symbol( input, c );
}
}
break;
case '.': case '.':
{ {
wint_t next = fgetwc( input ); wint_t next = fgetwc( input );
if ( iswdigit( next ) ) { if ( iswdigit( next ) ) {
ungetwc( next, input ); ungetwc( next, input );
result = read_number( input, c ); result =
read_number( frame, frame_pointer, input, c,
true );
} else if ( iswblank( next ) ) { } else if ( iswblank( next ) ) {
/* dotted pair. TODO: this isn't right, we /* dotted pair. TODO: this isn't right, we
* really need to backtrack up a level. */ * really need to backtrack up a level. */
result = result =
read_continuation( frame, input, fgetwc( input ) ); read_continuation( frame, frame_pointer, input,
fgetwc( input ) );
} else { } else {
read_symbol( input, c ); read_symbol( input, c );
} }
@ -102,40 +130,76 @@ struct cons_pointer read_continuation( struct stack_frame *frame, FILE * input,
break; break;
default: default:
if ( iswdigit( c ) ) { if ( iswdigit( c ) ) {
result = read_number( input, c ); result =
read_number( frame, frame_pointer, input, c, false );
} else if ( iswprint( c ) ) { } else if ( iswprint( c ) ) {
result = read_symbol( input, c ); result = read_symbol( input, c );
} else { } else {
result = result =
make_exception( c_string_to_lisp_string throw_exception( make_cons( c_string_to_lisp_string
( "Unrecognised start of input character" ), ( L"Unrecognised start of input character" ),
frame ); make_string( c, NIL ) ),
frame_pointer );
} }
break;
} }
} }
debug_print( L"read_continuation returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result; return result;
} }
/** /**
* read a number from this input stream, given this initial character. * read a number from this input stream, given this initial character.
* TODO: to be able to read bignums, we need to read the number from the
* input stream into a Lisp string, and then convert it to a number.
*/ */
struct cons_pointer read_number( FILE * input, wint_t initial ) { struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer,
FILE * input,
wint_t initial, bool seen_period ) {
debug_print( L"entering read_number\n", DEBUG_IO );
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
long int accumulator = 0; int64_t accumulator = 0;
int64_t dividend = 0;
int places_of_decimals = 0; int places_of_decimals = 0;
bool seen_period = false;
wint_t c; wint_t c;
fwprintf( stderr, L"read_number starting '%c' (%d)\n", initial, initial ); bool negative = initial == btowc( '-' );
if ( negative ) {
initial = fgetwc( input );
}
debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial );
for ( c = initial; iswdigit( c ) for ( c = initial; iswdigit( c )
|| c == btowc( '.' ); c = fgetwc( input ) ) { || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) {
if ( c == btowc( '.' ) ) { if ( c == btowc( '.' ) ) {
seen_period = true; if ( seen_period || dividend != 0 ) {
return throw_exception( c_string_to_lisp_string
( L"Malformed number: too many periods" ),
frame_pointer );
} else {
seen_period = true;
}
} else if ( c == btowc( '/' ) ) {
if ( seen_period || dividend > 0 ) {
return throw_exception( c_string_to_lisp_string
( L"Malformed number: dividend of rational must be integer" ),
frame_pointer );
} else {
dividend = negative ? 0 - accumulator : accumulator;
accumulator = 0;
}
} else { } else {
accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' );
fwprintf( stderr,
debug_printf( DEBUG_IO,
L"Added character %c, accumulator now %ld\n", L"Added character %c, accumulator now %ld\n",
c, accumulator ); c, accumulator );
if ( seen_period ) { if ( seen_period ) {
places_of_decimals++; places_of_decimals++;
} }
@ -149,12 +213,24 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
if ( seen_period ) { if ( seen_period ) {
long double rv = ( long double ) long double rv = ( long double )
( accumulator / pow( 10, places_of_decimals ) ); ( accumulator / pow( 10, places_of_decimals ) );
fwprintf( stderr, L"read_numer returning %Lf\n", rv ); if ( negative ) {
rv = 0 - rv;
}
result = make_real( rv ); result = make_real( rv );
} else if ( dividend != 0 ) {
result =
make_ratio( frame_pointer, make_integer( dividend ),
make_integer( accumulator ) );
} else { } else {
if ( negative ) {
accumulator = 0 - accumulator;
}
result = make_integer( accumulator ); result = make_integer( accumulator );
} }
debug_print( L"read_number returning\n", DEBUG_IO );
debug_dump_object( result, DEBUG_IO );
return result; return result;
} }
@ -162,18 +238,22 @@ struct cons_pointer read_number( FILE * input, wint_t initial ) {
* Read a list from this input stream, which no longer contains the opening * Read a list from this input stream, which no longer contains the opening
* left parenthesis. * left parenthesis.
*/ */
struct cons_pointer read_list( struct struct cons_pointer read_list( struct stack_frame *frame,
stack_frame struct cons_pointer frame_pointer,
*frame, FILE * input, wint_t initial ) { FILE * input, wint_t initial ) {
struct cons_pointer result = NIL; struct cons_pointer result = NIL;
if ( initial != ')' ) { if ( initial != ')' ) {
fwprintf( stderr, debug_printf( DEBUG_IO,
L"read_list starting '%C' (%d)\n", initial, initial ); L"read_list starting '%C' (%d)\n", initial, initial );
struct cons_pointer car = read_continuation( frame, input, struct cons_pointer car =
initial ); read_continuation( frame, frame_pointer, input,
result = make_cons( car, read_list( frame, input, fgetwc( input ) ) ); initial );
result =
make_cons( car,
read_list( frame, frame_pointer, input,
fgetwc( input ) ) );
} else { } else {
fwprintf( stderr, L"End of list detected\n" ); debug_print( L"End of list detected\n", DEBUG_IO );
} }
return result; return result;
@ -245,9 +325,9 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
break; break;
} }
fputws( L"Read symbol '", stderr ); debug_print( L"read_symbol returning\n", DEBUG_IO );
print( stderr, result ); debug_dump_object( result, DEBUG_IO );
fputws( L"'\n", stderr );
return result; return result;
} }
@ -256,6 +336,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) {
*/ */
struct cons_pointer read( struct struct cons_pointer read( struct
stack_frame stack_frame
*frame, FILE * input ) { *frame, struct cons_pointer frame_pointer,
return read_continuation( frame, input, fgetwc( input ) ); FILE * input ) {
return read_continuation( frame, frame_pointer, input, fgetwc( input ) );
} }

3
src/read.h → src/ops/read.h
View file

@ -14,6 +14,7 @@
/** /**
* read the next object on this input stream and return a cons_pointer to it. * 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 #endif

237
src/peano.c
View file

@ -1,237 +0,0 @@
/*
* peano.c
*
* Basic peano arithmetic
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <ctype.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <math.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "equal.h"
#include "integer.h"
#include "intern.h"
#include "lispops.h"
#include "print.h"
#include "read.h"
#include "real.h"
#include "stack.h"
/**
* Internal guts of add. Dark and mysterious.
*/
struct cons_pointer add_accumulate( struct cons_pointer arg,
struct stack_frame *frame,
long int *i_accumulator,
long double *d_accumulator, int *is_int ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
( *i_accumulator ) += cell.payload.integer.value;
( *d_accumulator ) += numeric_value( arg );
break;
case REALTV:
( *d_accumulator ) += cell.payload.real.value;
( *is_int ) &= false;
break;
case EXCEPTIONTV:
result = arg;
break;
default:
result = lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
}
return result;
}
/**
* Add an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_add( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
long int i_accumulator = 0;
long double d_accumulator = 0;
int is_int = true;
for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) {
result =
add_accumulate( frame->arg[i], frame, &i_accumulator,
&d_accumulator, &is_int );
}
struct cons_pointer more = frame->more;
while ( consp( more ) ) {
result =
add_accumulate( c_car( more ), frame, &i_accumulator,
&d_accumulator, &is_int );
more = c_cdr( more );
}
if ( is_int ) {
result = make_integer( i_accumulator );
} else {
result = make_real( d_accumulator );
}
return result;
}
/**
* Internal guts of multiply. Dark and mysterious.
*/
struct cons_pointer multiply_accumulate( struct cons_pointer arg,
struct stack_frame *frame,
long int *i_accumulator,
long double *d_accumulator,
int *is_int ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
switch ( cell.tag.value ) {
case INTEGERTV:
( *i_accumulator ) *= cell.payload.integer.value;
( *d_accumulator ) *= numeric_value( arg );
break;
case REALTV:
( *d_accumulator ) *= cell.payload.real.value;
( *is_int ) &= false;
break;
case EXCEPTIONTV:
result = arg;
break;
default:
result = lisp_throw( c_string_to_lisp_string
( "Cannot multiply: not a number" ), frame );
}
return result;
}
/**
* Multiply an indefinite number of numbers together
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_multiply( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
long int i_accumulator = 1;
long double d_accumulator = 1;
int is_int = true;
for ( int i = 0;
i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result );
i++ ) {
result =
multiply_accumulate( frame->arg[i], frame, &i_accumulator,
&d_accumulator, &is_int );
}
struct cons_pointer more = frame->more;
while ( consp( more ) && !exceptionp( result ) ) {
result =
multiply_accumulate( c_car( more ), frame, &i_accumulator,
&d_accumulator, &is_int );
more = c_cdr( more );
}
if ( !exceptionp( result ) ) {
if ( is_int ) {
result = make_integer( i_accumulator );
} else {
result = make_real( d_accumulator );
}
}
return result;
}
/**
* Subtract one number from another.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_subtract( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
if ( integerp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
result =
make_integer( arg0.payload.integer.value -
arg1.payload.integer.value );
} else if ( realp( frame->arg[0] ) && realp( frame->arg[1] ) ) {
result =
make_real( arg0.payload.real.value - arg1.payload.real.value );
} else if ( integerp( frame->arg[0] ) && realp( frame->arg[1] ) ) {
result =
make_real( numeric_value( frame->arg[0] ) -
arg1.payload.real.value );
} else if ( realp( frame->arg[0] ) && integerp( frame->arg[1] ) ) {
result =
make_real( arg0.payload.real.value -
numeric_value( frame->arg[1] ) );
} else {
/* TODO: throw an exception */
lisp_throw( c_string_to_lisp_string
( "Cannot subtract: not a number" ), frame );
}
// and if not nilp[frame->arg[2]) we also have an error.
return result;
}
/**
* Divide one number by another.
* @param env the evaluation environment - ignored;
* @param frame the stack frame.
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_divide( struct stack_frame *frame, struct cons_pointer env ) {
struct cons_pointer result = NIL;
struct cons_space_object arg0 = pointer2cell( frame->arg[0] );
struct cons_space_object arg1 = pointer2cell( frame->arg[1] );
if ( numberp( frame->arg[1] ) && numeric_value( frame->arg[1] ) == 0 ) {
lisp_throw( c_string_to_lisp_string
( "Cannot divide: divisor is zero" ), frame );
} else if ( numberp( frame->arg[0] ) && numberp( frame->arg[1] ) ) {
long int i = ( long int ) numeric_value( frame->arg[0] ) /
numeric_value( frame->arg[1] );
long double r = ( long double ) numeric_value( frame->arg[0] ) /
numeric_value( frame->arg[1] );
if ( fabsl( ( long double ) i - r ) < 0.0000000001 ) {
result = make_integer( i );
} else {
result = make_real( r );
}
} else {
lisp_throw( c_string_to_lisp_string
( "Cannot divide: not a number" ), frame );
}
return result;
}

65
src/repl.c
View file

@ -13,6 +13,7 @@
#include "conspage.h" #include "conspage.h"
#include "consspaceobject.h" #include "consspaceobject.h"
#include "debug.h"
#include "intern.h" #include "intern.h"
#include "lispops.h" #include "lispops.h"
#include "read.h" #include "read.h"
@ -31,11 +32,18 @@
* Dummy up a Lisp read call with its own stack frame. * Dummy up a Lisp read call with its own stack frame.
*/ */
struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { struct cons_pointer repl_read( struct cons_pointer stream_pointer ) {
struct stack_frame *frame = make_empty_frame( NULL, oblist ); struct cons_pointer result = NIL;
debug_print( L"Entered repl_read\n", DEBUG_REPL );
frame->arg[0] = stream_pointer; struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons(stream_pointer, NIL), oblist );
struct cons_pointer result = lisp_read( frame, oblist ); debug_print( L"repl_read: got stack_frame pointer\n", DEBUG_REPL );
free_stack_frame( frame ); 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; 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. * Dummy up a Lisp eval call with its own stack frame.
*/ */
struct cons_pointer repl_eval( struct cons_pointer input ) { struct cons_pointer repl_eval( struct cons_pointer input ) {
struct stack_frame *frame = make_empty_frame( NULL, oblist ); debug_print( L"Entered repl_eval\n", DEBUG_REPL );
struct cons_pointer result = NIL;
frame->arg[0] = input; result = eval_form( NULL, NIL, input, oblist );
struct cons_pointer result = lisp_eval( frame, oblist );
if ( !exceptionp( result ) ) { debug_print( L"repl_eval: returning\n", DEBUG_REPL );
free_stack_frame( frame ); debug_dump_object( result, DEBUG_REPL );
}
return result; 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 repl_print( struct cons_pointer stream_pointer,
struct cons_pointer value ) { struct cons_pointer value ) {
struct stack_frame *frame = make_empty_frame( NULL, oblist ); debug_print( L"Entered repl_print\n", DEBUG_REPL );
debug_dump_object( value, DEBUG_REPL );
frame->arg[0] = value; struct cons_pointer result =
frame->arg[1] = NIL /* stream_pointer */ ; print( pointer2cell( stream_pointer ).payload.stream.stream, value );
struct cons_pointer result = lisp_print( frame, oblist ); debug_print( L"repl_print: returning\n", DEBUG_REPL );
free_stack_frame( frame ); debug_dump_object( result, DEBUG_REPL );
return result; return result;
} }
@ -81,30 +88,30 @@ struct cons_pointer repl_print( struct cons_pointer stream_pointer,
void void
repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, repl( FILE * in_stream, FILE * out_stream, FILE * error_stream,
bool show_prompt ) { bool show_prompt ) {
debug_print( L"Entered repl\n", DEBUG_REPL );
struct cons_pointer input_stream = make_read_stream( in_stream ); struct cons_pointer input_stream = make_read_stream( in_stream );
struct cons_pointer output_stream = make_write_stream( out_stream ); inc_ref( input_stream );
struct cons_pointer output_stream = make_write_stream( out_stream );
inc_ref( output_stream );
while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) { while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
if ( show_prompt ) { if ( show_prompt ) {
fwprintf( out_stream, L"\n:: " ); fwprintf( out_stream, L"\n:: " );
} }
struct cons_pointer input = repl_read( input_stream ); struct cons_pointer input = repl_read( input_stream );
inc_ref( input );
if ( exceptionp( input ) ) { if ( exceptionp( input ) ) {
/* suppress the end-of-stream exception */
if ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
repl_print( output_stream, input );
}
break; break;
} else { } else {
repl_print( output_stream, repl_eval( input ) );
struct cons_pointer val = repl_eval( input );
if ( feof( pointer2cell( input_stream ).payload.stream.stream ) ) {
/* suppress the 'end of stream' exception */
if ( !exceptionp( val ) ) {
repl_print( output_stream, val );
}
} else {
repl_print( output_stream, val );
}
} }
dec_ref( input );
} }
debug_print( L"Leaving repl\n", DEBUG_REPL );
} }

206
src/stack.c
View file

@ -1,206 +0,0 @@
/*
* stack.c
*
* The Lisp evaluation stack.
*
* Stack frames could be implemented in cons space; indeed, the stack
* could simply be an assoc list consed onto the front of the environment.
* But such a stack would be costly to search. The design sketched here,
* with stack frames as special objects, SHOULD be substantially more
* efficient, but does imply we need to generalise the idea of cons pages
* with freelists to a more general 'equal sized object pages', so that
* allocating/freeing stack frames can be more efficient.
*
* Stack frames are not yet a first class object; they have no VECP pointer
* in cons space.
*
* (c) 2017 Simon Brooke <simon@journeyman.cc>
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
#include <stdlib.h>
#include "consspaceobject.h"
#include "conspage.h"
#include "lispops.h"
#include "print.h"
#include "stack.h"
/**
* Make an empty stack frame, and return it.
* @param previous the current top-of-stack;
* @param env the environment in which evaluation happens.
* @return the new frame.
*/
struct stack_frame *make_empty_frame( struct stack_frame *previous,
struct cons_pointer env ) {
struct stack_frame *result = malloc( sizeof( struct stack_frame ) );
/*
* TODO: later, pop a frame off a free-list of stack frames
*/
result->previous = previous;
/*
* clearing the frame with memset would probably be slightly quicker, but
* this is clear.
*/
result->more = NIL;
result->function = NIL;
for ( int i = 0; i < args_in_frame; i++ ) {
result->arg[i] = NIL;
}
return result;
}
/**
* Allocate a new stack frame with its previous pointer set to this value,
* its arguments set up from these args, evaluated in this env.
* @param previous the current top-of-stack;
* @args the arguments to load into this frame;
* @param env the environment in which evaluation happens.
* @return the new frame.
*/
struct stack_frame *make_stack_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env,
struct cons_pointer *exception ) {
struct stack_frame *result = make_empty_frame( previous, env );
for ( int i = 0; i < args_in_frame && consp( args ); i++ ) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
/*
* TODO: if we were running on real massively parallel hardware,
* each arg except the first should be handed off to another
* processor to be evaled in parallel; but see notes here:
* https://github.com/simon-brooke/post-scarcity/wiki/parallelism
*/
struct stack_frame *arg_frame = make_empty_frame( result, env );
arg_frame->arg[0] = cell.payload.cons.car;
inc_ref( arg_frame->arg[0] );
struct cons_pointer val = lisp_eval( arg_frame, env );
if ( exceptionp( val ) ) {
exception = &val;
break;
} else {
result->arg[i] = val;
}
inc_ref( val );
free_stack_frame( arg_frame );
args = cell.payload.cons.cdr;
}
if ( consp( args ) ) {
/* if we still have args, eval them and stick the values on `more` */
struct cons_pointer more = eval_forms( previous, args, env );
result->more = more;
inc_ref( more );
}
dump_frame( stderr, result );
return result;
}
/**
* A 'special' frame is exactly like a normal stack frame except that the
* arguments are unevaluated.
* @param previous the previous stack frame;
* @param args a list of the arguments to be stored in this stack frame;
* @param env the execution environment;
* @return a new special frame.
*/
struct stack_frame *make_special_frame( struct stack_frame *previous,
struct cons_pointer args,
struct cons_pointer env ) {
struct stack_frame *result = make_empty_frame( previous, env );
for ( int i = 0; i < args_in_frame && !nilp( args ); i++ ) {
/* iterate down the arg list filling in the arg slots in the
* frame. When there are no more slots, if there are still args,
* stash them on more */
struct cons_space_object cell = pointer2cell( args );
result->arg[i] = cell.payload.cons.car;
inc_ref( result->arg[i] );
args = cell.payload.cons.cdr;
}
if ( consp( args ) ) {
result->more = args;
inc_ref( args );
}
return result;
}
/**
* Free this stack frame.
*/
void free_stack_frame( struct stack_frame *frame ) {
/*
* TODO: later, push it back on the stack-frame freelist
*/
for ( int i = 0; i < args_in_frame; i++ ) {
dec_ref( frame->arg[i] );
}
if ( !nilp( frame->more ) ) {
dec_ref( frame->more );
}
free( frame );
}
/**
* Dump a stackframe to this stream for debugging
* @param output the stream
* @param frame the frame
*/
void dump_frame( FILE * output, struct stack_frame *frame ) {
fputws( L"Dumping stack frame\n", output );
for ( int arg = 0; arg < args_in_frame; arg++ ) {
struct cons_space_object cell = pointer2cell( frame->arg[arg] );
fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg,
cell.tag.bytes[0],
cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3],
cell.count );
print( output, frame->arg[arg] );
fputws( L"\n", output );
}
fputws( L"More: \t", output );
print( output, frame->more );
fputws( L"\n", output );
}
/**
* Fetch a pointer to the value of the local variable at this index.
*/
struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int index ) {
struct cons_pointer result = NIL;
if ( index < args_in_frame ) {
result = frame->arg[index];
} else {
struct cons_pointer p = frame->more;
for ( int i = args_in_frame; i < index; i++ ) {
p = pointer2cell( p ).payload.cons.cdr;
}
result = pointer2cell( p ).payload.cons.car;
}
return result;
}

2
src/version.h
View file

@ -8,4 +8,4 @@
* Licensed under GPL version 2.0, or, at your option, any later version. * Licensed under GPL version 2.0, or, at your option, any later version.
*/ */
#define VERSION "0.0.3" #define VERSION "0.0.4"

54
unit-tests/add.sh
View file

@ -23,3 +23,57 @@ else
exit 1 exit 1
fi fi
expected='1/4'
actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
# (+ integer ratio) should be ratio
expected='25/4'
actual=`echo "(+ 6 1/4)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
# (+ ratio integer) should be ratio
expected='25/4'
actual=`echo "(+ 1/4 6)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
# (+ real ratio) should be real
# for this test, trailing zeros can be ignored
expected='6.25'
actual=`echo "(+ 6.000000001 1/4)" |\
target/psse 2> /dev/null |\
sed 's/0*$//' |\
head -2 |\
tail -1`
outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc`
if [ "${outcome}" = "1" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

13
unit-tests/nlambda.sh Normal file
View file

@ -0,0 +1,13 @@
#!/bin/bash
expected='a'
actual=`echo "((nlambda (x) x) a)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

12
unit-tests/ratio-addition.sh Normal file
View file

@ -0,0 +1,12 @@
#!/bin/bash
expected='1/4'
actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

36
unit-tests/reverse.sh Normal file
View file

@ -0,0 +1,36 @@
#!/bin/bash
expected='"god yzal eht revo depmuj xof nworb kciuq ehT"'
actual=`echo '(reverse "The quick brown fox jumped over the lazy dog")' | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
expected='(1024 512 256 128 64 32 16 8 4 2)'
actual=`echo "(reverse '(2 4 8 16 32 64 128 256 512 1024))" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
expected='esrever'
actual=`echo "(reverse 'reverse)" | target/psse 2> /dev/null | head -2 | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi

10
unit-tests/string-allocation.sh
View file

@ -1,17 +1,15 @@
#!/bin/bash #!/bin/bash
log=log.$$
value='"Fred"' value='"Fred"'
expected="String cell: character 'F' (70)" expected="String cell: character 'F'"
echo ${value} | target/psse -d > ${log} 2>/dev/null # set! protects "Fred" from the garbage collector.
grep "${expected}" ${log} > /dev/null actual=`echo "(set! x ${value})" | target/psse -d 2>&1 | grep "$expected" | sed 's/ *\(.*\) next.*$/\1/'`
if [ $? -eq 0 ] if [ $? -eq 0 ]
then then
echo "OK" echo "OK"
rm ${log}
exit 0 exit 0
else else
echo "Expected '${expected}', not found in ${log}" echo "Fail: expected '${expected}', got '${actual}'"
exit 1 exit 1
fi fi

BIN
utils_src/debugflags/debugflags Executable file
View file

Binary file not shown.

43
utils_src/debugflags/debugflags.c Normal file
View file

@ -0,0 +1,43 @@
#include <inttypes.h>
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.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
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);
}
}

17
utils_src/readprintwc/readprintwc.c Normal file
View file

@ -0,0 +1,17 @@
#include <stdio.h>
#include <stdlib.h>
#include <wchar.h>
#include <wctype.h>
int main( int argc, char *argv[] ) {
fwide( stdin, 1 );
fwide( stdout, 1 );
for (wchar_t c = fgetwc( stdin ); !feof( stdin); c = fgetwc( stdin )) {
if (c != '\n') {
fwprintf( stdout, L"Read character %d, %C\t", (int)c, c);
fputwc( c, stdout);
fputws(L"\n", stdout);
}
}
}

26
utils_src/tagvalcalc/tagvalcalc.c Normal file
View file

@ -0,0 +1,26 @@
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#define TAGLENGTH 4
struct dummy {
union {
char bytes[TAGLENGTH]; /* the tag (type) of this cell,
* considered as bytes */
uint32_t value; /* the tag considered as a number */
} tag;
};
int main( int argc, char *argv[] ) {
struct dummy *b = malloc( sizeof( struct dummy));
struct dummy buffer = *b;
for (int i = 1; i < argc; i++) {
strncpy( &buffer.tag.bytes[0], argv[i], TAGLENGTH );
printf( "%4.4s:\t%d\n", argv[i], buffer.tag.value);
}
}

BIN
utils_src/tagvalcalc/tvc Executable file
View file

Binary file not shown.