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
\.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.
# The default value is: My Project.
PROJECT_NAME = "\"Post Scarcity\""
PROJECT_NAME = "Post Scarcity"
# The PROJECT_NUMBER tag can be used to enter a project or revision number. This
# could be handy for archiving the generated documentation or if some version
# control system is used.
PROJECT_NUMBER =
PROJECT_NUMBER =
# Using the PROJECT_BRIEF tag one can provide an optional one line description
# for a project that appears at the top of each page and should give viewer a
@ -51,14 +51,14 @@ PROJECT_BRIEF = "A prototype for a post scarcity programming environmen
# pixels and the maximum width should not exceed 200 pixels. Doxygen will copy
# the logo to the output directory.
PROJECT_LOGO =
PROJECT_LOGO =
# The OUTPUT_DIRECTORY tag is used to specify the (relative or absolute) path
# into which the generated documentation will be written. If a relative path is
# entered, it will be relative to the location where doxygen was started. If
# left blank the current directory will be used.
OUTPUT_DIRECTORY = /home/simon/workspace/post-scarcity/doc
OUTPUT_DIRECTORY = doc
# If the CREATE_SUBDIRS tag is set to YES then doxygen will create 4096 sub-
# directories (in 2 levels) under the output directory of each output format and
@ -162,7 +162,7 @@ FULL_PATH_NAMES = YES
# will be relative from the directory where doxygen is started.
# This tag requires that the tag FULL_PATH_NAMES is set to YES.
STRIP_FROM_PATH =
STRIP_FROM_PATH =
# The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the
# path mentioned in the documentation of a class, which tells the reader which
@ -171,7 +171,7 @@ STRIP_FROM_PATH =
# specify the list of include paths that are normally passed to the compiler
# using the -I flag.
STRIP_FROM_INC_PATH =
STRIP_FROM_INC_PATH =
# If the SHORT_NAMES tag is set to YES, doxygen will generate much shorter (but
# less readable) file names. This can be useful is your file systems doesn't
@ -238,13 +238,13 @@ TAB_SIZE = 4
# "Side Effects:". You can put \n's in the value part of an alias to insert
# newlines.
ALIASES =
ALIASES =
# This tag can be used to specify a number of word-keyword mappings (TCL only).
# A mapping has the form "name=value". For example adding "class=itcl::class"
# will allow you to use the command class in the itcl::class meaning.
TCL_SUBST =
TCL_SUBST =
# Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources
# only. Doxygen will then generate output that is more tailored for C. For
@ -291,7 +291,7 @@ OPTIMIZE_OUTPUT_VHDL = NO
# Note that for custom extensions you also need to set FILE_PATTERNS otherwise
# the files are not read by doxygen.
EXTENSION_MAPPING =
EXTENSION_MAPPING =
# If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments
# according to the Markdown format, which allows for more readable
@ -648,7 +648,7 @@ GENERATE_DEPRECATEDLIST= YES
# sections, marked by \if <section_label> ... \endif and \cond <section_label>
# ... \endcond blocks.
ENABLED_SECTIONS =
ENABLED_SECTIONS =
# The MAX_INITIALIZER_LINES tag determines the maximum number of lines that the
# initial value of a variable or macro / define can have for it to appear in the
@ -690,7 +690,7 @@ SHOW_NAMESPACES = YES
# by doxygen. Whatever the program writes to standard output is used as the file
# version. For an example see the documentation.
FILE_VERSION_FILTER =
FILE_VERSION_FILTER =
# The LAYOUT_FILE tag can be used to specify a layout file which will be parsed
# by doxygen. The layout file controls the global structure of the generated
@ -703,7 +703,7 @@ FILE_VERSION_FILTER =
# DoxygenLayout.xml, doxygen will parse it automatically even if the LAYOUT_FILE
# tag is left empty.
LAYOUT_FILE =
LAYOUT_FILE =
# The CITE_BIB_FILES tag can be used to specify one or more bib files containing
# the reference definitions. This must be a list of .bib files. The .bib
@ -713,7 +713,7 @@ LAYOUT_FILE =
# LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the
# search path. See also \cite for info how to create references.
CITE_BIB_FILES =
CITE_BIB_FILES =
#---------------------------------------------------------------------------
# Configuration options related to warning and progress messages
@ -778,7 +778,7 @@ WARN_FORMAT = "$file:$line: $text"
# messages should be written. If left blank the output is written to standard
# error (stderr).
WARN_LOGFILE =
WARN_LOGFILE = doxy.log
#---------------------------------------------------------------------------
# Configuration options related to the input files
@ -790,7 +790,7 @@ WARN_LOGFILE =
# spaces. See also FILE_PATTERNS and EXTENSION_MAPPING
# Note: If this tag is empty the current directory is searched.
INPUT = /home/simon/workspace/post-scarcity/src
INPUT = src src/arith src/memory src/ops
# This tag can be used to specify the character encoding of the source files
# that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses
@ -873,7 +873,7 @@ RECURSIVE = NO
# Note that relative paths are relative to the directory from which doxygen is
# run.
EXCLUDE =
EXCLUDE =
# The EXCLUDE_SYMLINKS tag can be used to select whether or not files or
# directories that are symbolic links (a Unix file system feature) are excluded
@ -889,7 +889,7 @@ EXCLUDE_SYMLINKS = NO
# Note that the wildcards are matched against the file with absolute path, so to
# exclude all test directories for example use the pattern */test/*
EXCLUDE_PATTERNS =
EXCLUDE_PATTERNS =
# The EXCLUDE_SYMBOLS tag can be used to specify one or more symbol names
# (namespaces, classes, functions, etc.) that should be excluded from the
@ -900,13 +900,13 @@ EXCLUDE_PATTERNS =
# Note that the wildcards are matched against the file with absolute path, so to
# exclude all test directories use the pattern */test/*
EXCLUDE_SYMBOLS =
EXCLUDE_SYMBOLS =
# The EXAMPLE_PATH tag can be used to specify one or more files or directories
# that contain example code fragments that are included (see the \include
# command).
EXAMPLE_PATH =
EXAMPLE_PATH =
# If the value of the EXAMPLE_PATH tag contains directories, you can use the
# EXAMPLE_PATTERNS tag to specify one or more wildcard pattern (like *.cpp and
@ -926,7 +926,7 @@ EXAMPLE_RECURSIVE = NO
# that contain images that are to be included in the documentation (see the
# \image command).
IMAGE_PATH =
IMAGE_PATH =
# The INPUT_FILTER tag can be used to specify a program that doxygen should
# invoke to filter for each input file. Doxygen will invoke the filter program
@ -947,7 +947,7 @@ IMAGE_PATH =
# need to set EXTENSION_MAPPING for the extension otherwise the files are not
# properly processed by doxygen.
INPUT_FILTER =
INPUT_FILTER =
# The FILTER_PATTERNS tag can be used to specify filters on a per file pattern
# basis. Doxygen will compare the file name with each pattern and apply the
@ -960,7 +960,7 @@ INPUT_FILTER =
# need to set EXTENSION_MAPPING for the extension otherwise the files are not
# properly processed by doxygen.
FILTER_PATTERNS =
FILTER_PATTERNS =
# If the FILTER_SOURCE_FILES tag is set to YES, the input filter (if set using
# INPUT_FILTER) will also be used to filter the input files that are used for
@ -975,14 +975,14 @@ FILTER_SOURCE_FILES = NO
# *.ext= (so without naming a filter).
# This tag requires that the tag FILTER_SOURCE_FILES is set to YES.
FILTER_SOURCE_PATTERNS =
FILTER_SOURCE_PATTERNS =
# If the USE_MDFILE_AS_MAINPAGE tag refers to the name of a markdown file that
# is part of the input, its contents will be placed on the main page
# (index.html). This can be useful if you have a project on for instance GitHub
# and want to reuse the introduction page also for the doxygen output.
USE_MDFILE_AS_MAINPAGE =
USE_MDFILE_AS_MAINPAGE =
#---------------------------------------------------------------------------
# Configuration options related to source browsing
@ -1087,7 +1087,7 @@ CLANG_ASSISTED_PARSING = NO
# specified with INPUT and INCLUDE_PATH.
# This tag requires that the tag CLANG_ASSISTED_PARSING is set to YES.
CLANG_OPTIONS =
CLANG_OPTIONS =
#---------------------------------------------------------------------------
# Configuration options related to the alphabetical class index
@ -1113,7 +1113,7 @@ COLS_IN_ALPHA_INDEX = 5
# while generating the index headers.
# This tag requires that the tag ALPHABETICAL_INDEX is set to YES.
IGNORE_PREFIX =
IGNORE_PREFIX =
#---------------------------------------------------------------------------
# Configuration options related to the HTML output
@ -1157,7 +1157,7 @@ HTML_FILE_EXTENSION = .html
# of the possible markers and block names see the documentation.
# This tag requires that the tag GENERATE_HTML is set to YES.
HTML_HEADER =
HTML_HEADER =
# The HTML_FOOTER tag can be used to specify a user-defined HTML footer for each
# generated HTML page. If the tag is left blank doxygen will generate a standard
@ -1167,7 +1167,7 @@ HTML_HEADER =
# that doxygen normally uses.
# This tag requires that the tag GENERATE_HTML is set to YES.
HTML_FOOTER =
HTML_FOOTER =
# The HTML_STYLESHEET tag can be used to specify a user-defined cascading style
# sheet that is used by each HTML page. It can be used to fine-tune the look of
@ -1179,7 +1179,7 @@ HTML_FOOTER =
# obsolete.
# This tag requires that the tag GENERATE_HTML is set to YES.
HTML_STYLESHEET =
HTML_STYLESHEET =
# The HTML_EXTRA_STYLESHEET tag can be used to specify additional user-defined
# cascading style sheets that are included after the standard style sheets
@ -1192,7 +1192,7 @@ HTML_STYLESHEET =
# list). For an example see the documentation.
# This tag requires that the tag GENERATE_HTML is set to YES.
HTML_EXTRA_STYLESHEET =
HTML_EXTRA_STYLESHEET =
# The HTML_EXTRA_FILES tag can be used to specify one or more extra images or
# other source files which should be copied to the HTML output directory. Note
@ -1202,7 +1202,7 @@ HTML_EXTRA_STYLESHEET =
# files will be copied as-is; there are no commands or markers available.
# This tag requires that the tag GENERATE_HTML is set to YES.
HTML_EXTRA_FILES =
HTML_EXTRA_FILES =
# The HTML_COLORSTYLE_HUE tag controls the color of the HTML output. Doxygen
# will adjust the colors in the style sheet and background images according to
@ -1331,7 +1331,7 @@ GENERATE_HTMLHELP = NO
# written to the html output directory.
# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
CHM_FILE =
CHM_FILE =
# The HHC_LOCATION tag can be used to specify the location (absolute path
# including file name) of the HTML help compiler (hhc.exe). If non-empty,
@ -1339,7 +1339,7 @@ CHM_FILE =
# The file has to be specified with full path.
# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
HHC_LOCATION =
HHC_LOCATION =
# The GENERATE_CHI flag controls if a separate .chi index file is generated
# (YES) or that it should be included in the master .chm file (NO).
@ -1352,7 +1352,7 @@ GENERATE_CHI = NO
# and project file content.
# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
CHM_INDEX_ENCODING =
CHM_INDEX_ENCODING =
# The BINARY_TOC flag controls whether a binary table of contents is generated
# (YES) or a normal table of contents (NO) in the .chm file. Furthermore it
@ -1383,7 +1383,7 @@ GENERATE_QHP = NO
# the HTML output folder.
# This tag requires that the tag GENERATE_QHP is set to YES.
QCH_FILE =
QCH_FILE =
# The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help
# Project output. For more information please see Qt Help Project / Namespace
@ -1408,7 +1408,7 @@ QHP_VIRTUAL_FOLDER = doc
# filters).
# This tag requires that the tag GENERATE_QHP is set to YES.
QHP_CUST_FILTER_NAME =
QHP_CUST_FILTER_NAME =
# The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the
# custom filter to add. For more information please see Qt Help Project / Custom
@ -1416,21 +1416,21 @@ QHP_CUST_FILTER_NAME =
# filters).
# This tag requires that the tag GENERATE_QHP is set to YES.
QHP_CUST_FILTER_ATTRS =
QHP_CUST_FILTER_ATTRS =
# The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this
# project's filter section matches. Qt Help Project / Filter Attributes (see:
# http://qt-project.org/doc/qt-4.8/qthelpproject.html#filter-attributes).
# This tag requires that the tag GENERATE_QHP is set to YES.
QHP_SECT_FILTER_ATTRS =
QHP_SECT_FILTER_ATTRS =
# The QHG_LOCATION tag can be used to specify the location of Qt's
# qhelpgenerator. If non-empty doxygen will try to run qhelpgenerator on the
# generated .qhp file.
# This tag requires that the tag GENERATE_QHP is set to YES.
QHG_LOCATION =
QHG_LOCATION =
# If the GENERATE_ECLIPSEHELP tag is set to YES, additional index files will be
# generated, together with the HTML files, they form an Eclipse help plugin. To
@ -1563,7 +1563,7 @@ MATHJAX_RELPATH = http://cdn.mathjax.org/mathjax/latest
# MATHJAX_EXTENSIONS = TeX/AMSmath TeX/AMSsymbols
# This tag requires that the tag USE_MATHJAX is set to YES.
MATHJAX_EXTENSIONS =
MATHJAX_EXTENSIONS =
# The MATHJAX_CODEFILE tag can be used to specify a file with javascript pieces
# of code that will be used on startup of the MathJax code. See the MathJax site
@ -1571,7 +1571,7 @@ MATHJAX_EXTENSIONS =
# example see the documentation.
# This tag requires that the tag USE_MATHJAX is set to YES.
MATHJAX_CODEFILE =
MATHJAX_CODEFILE =
# When the SEARCHENGINE tag is enabled doxygen will generate a search box for
# the HTML output. The underlying search engine uses javascript and DHTML and
@ -1631,7 +1631,7 @@ EXTERNAL_SEARCH = NO
# Searching" for details.
# This tag requires that the tag SEARCHENGINE is set to YES.
SEARCHENGINE_URL =
SEARCHENGINE_URL =
# When SERVER_BASED_SEARCH and EXTERNAL_SEARCH are both enabled the unindexed
# search data is written to a file for indexing by an external tool. With the
@ -1647,7 +1647,7 @@ SEARCHDATA_FILE = searchdata.xml
# projects and redirect the results back to the right project.
# This tag requires that the tag SEARCHENGINE is set to YES.
EXTERNAL_SEARCH_ID =
EXTERNAL_SEARCH_ID =
# The EXTRA_SEARCH_MAPPINGS tag can be used to enable searching through doxygen
# projects other than the one defined by this configuration file, but that are
@ -1657,7 +1657,7 @@ EXTERNAL_SEARCH_ID =
# EXTRA_SEARCH_MAPPINGS = tagname1=loc1 tagname2=loc2 ...
# This tag requires that the tag SEARCHENGINE is set to YES.
EXTRA_SEARCH_MAPPINGS =
EXTRA_SEARCH_MAPPINGS =
#---------------------------------------------------------------------------
# Configuration options related to the LaTeX output
@ -1721,7 +1721,7 @@ PAPER_TYPE = a4
# If left blank no extra packages will be included.
# This tag requires that the tag GENERATE_LATEX is set to YES.
EXTRA_PACKAGES =
EXTRA_PACKAGES =
# The LATEX_HEADER tag can be used to specify a personal LaTeX header for the
# generated LaTeX document. The header should contain everything until the first
@ -1737,7 +1737,7 @@ EXTRA_PACKAGES =
# to HTML_HEADER.
# This tag requires that the tag GENERATE_LATEX is set to YES.
LATEX_HEADER =
LATEX_HEADER =
# The LATEX_FOOTER tag can be used to specify a personal LaTeX footer for the
# generated LaTeX document. The footer should contain everything after the last
@ -1748,7 +1748,7 @@ LATEX_HEADER =
# Note: Only use a user-defined footer if you know what you are doing!
# This tag requires that the tag GENERATE_LATEX is set to YES.
LATEX_FOOTER =
LATEX_FOOTER =
# The LATEX_EXTRA_STYLESHEET tag can be used to specify additional user-defined
# LaTeX style sheets that are included after the standard style sheets created
@ -1759,7 +1759,7 @@ LATEX_FOOTER =
# list).
# This tag requires that the tag GENERATE_LATEX is set to YES.
LATEX_EXTRA_STYLESHEET =
LATEX_EXTRA_STYLESHEET =
# The LATEX_EXTRA_FILES tag can be used to specify one or more extra images or
# other source files which should be copied to the LATEX_OUTPUT output
@ -1767,7 +1767,7 @@ LATEX_EXTRA_STYLESHEET =
# markers available.
# This tag requires that the tag GENERATE_LATEX is set to YES.
LATEX_EXTRA_FILES =
LATEX_EXTRA_FILES =
# If the PDF_HYPERLINKS tag is set to YES, the LaTeX that is generated is
# prepared for conversion to PDF (using ps2pdf or pdflatex). The PDF file will
@ -1875,14 +1875,14 @@ RTF_HYPERLINKS = NO
# default style sheet that doxygen normally uses.
# This tag requires that the tag GENERATE_RTF is set to YES.
RTF_STYLESHEET_FILE =
RTF_STYLESHEET_FILE =
# Set optional variables used in the generation of an RTF document. Syntax is
# similar to doxygen's config file. A template extensions file can be generated
# using doxygen -e rtf extensionFile.
# This tag requires that the tag GENERATE_RTF is set to YES.
RTF_EXTENSIONS_FILE =
RTF_EXTENSIONS_FILE =
# If the RTF_SOURCE_CODE tag is set to YES then doxygen will include source code
# with syntax highlighting in the RTF output.
@ -1927,7 +1927,7 @@ MAN_EXTENSION = .3
# MAN_EXTENSION with the initial . removed.
# This tag requires that the tag GENERATE_MAN is set to YES.
MAN_SUBDIR =
MAN_SUBDIR =
# If the MAN_LINKS tag is set to YES and doxygen generates man output, then it
# will generate one additional man file for each entity documented in the real
@ -2040,7 +2040,7 @@ PERLMOD_PRETTY = YES
# overwrite each other's variables.
# This tag requires that the tag GENERATE_PERLMOD is set to YES.
PERLMOD_MAKEVAR_PREFIX =
PERLMOD_MAKEVAR_PREFIX =
#---------------------------------------------------------------------------
# Configuration options related to the preprocessor
@ -2081,7 +2081,7 @@ SEARCH_INCLUDES = YES
# preprocessor.
# This tag requires that the tag SEARCH_INCLUDES is set to YES.
INCLUDE_PATH =
INCLUDE_PATH =
# You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard
# patterns (like *.h and *.hpp) to filter out the header-files in the
@ -2089,7 +2089,7 @@ INCLUDE_PATH =
# used.
# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
INCLUDE_FILE_PATTERNS =
INCLUDE_FILE_PATTERNS =
# The PREDEFINED tag can be used to specify one or more macro names that are
# defined before the preprocessor is started (similar to the -D option of e.g.
@ -2099,7 +2099,7 @@ INCLUDE_FILE_PATTERNS =
# recursively expanded use the := operator instead of the = operator.
# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
PREDEFINED =
PREDEFINED =
# If the MACRO_EXPANSION and EXPAND_ONLY_PREDEF tags are set to YES then this
# tag can be used to specify a list of macro names that should be expanded. The
@ -2108,7 +2108,7 @@ PREDEFINED =
# definition found in the source code.
# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
EXPAND_AS_DEFINED =
EXPAND_AS_DEFINED =
# If the SKIP_FUNCTION_MACROS tag is set to YES then doxygen's preprocessor will
# remove all references to function-like macros that are alone on a line, have
@ -2137,13 +2137,13 @@ SKIP_FUNCTION_MACROS = YES
# the path). If a tag file is not located in the directory in which doxygen is
# run, you must also specify the path to the tagfile here.
TAGFILES =
TAGFILES =
# When a file name is specified after GENERATE_TAGFILE, doxygen will create a
# tag file that is based on the input files it reads. See section "Linking to
# external documentation" for more information about the usage of tag files.
GENERATE_TAGFILE =
GENERATE_TAGFILE =
# If the ALLEXTERNALS tag is set to YES, all external class will be listed in
# the class index. If set to NO, only the inherited external classes will be
@ -2192,14 +2192,14 @@ CLASS_DIAGRAMS = YES
# the mscgen tool resides. If left empty the tool is assumed to be found in the
# default search path.
MSCGEN_PATH =
MSCGEN_PATH =
# You can include diagrams made with dia in doxygen documentation. Doxygen will
# then run dia to produce the diagram and insert it in the documentation. The
# DIA_PATH tag allows you to specify the directory where the dia binary resides.
# If left empty dia is assumed to be found in the default search path.
DIA_PATH =
DIA_PATH =
# If set to YES the inheritance and collaboration graphs will hide inheritance
# and usage relations if the target is undocumented or is not a class.
@ -2248,7 +2248,7 @@ DOT_FONTSIZE = 10
# the path where dot can find it using this tag.
# This tag requires that the tag HAVE_DOT is set to YES.
DOT_FONTPATH =
DOT_FONTPATH =
# If the CLASS_GRAPH tag is set to YES then doxygen will generate a graph for
# each documented class showing the direct and indirect inheritance relations.
@ -2394,26 +2394,26 @@ INTERACTIVE_SVG = YES
# found. If left blank, it is assumed the dot tool can be found in the path.
# This tag requires that the tag HAVE_DOT is set to YES.
DOT_PATH =
DOT_PATH =
# The DOTFILE_DIRS tag can be used to specify one or more directories that
# contain dot files that are included in the documentation (see the \dotfile
# command).
# This tag requires that the tag HAVE_DOT is set to YES.
DOTFILE_DIRS =
DOTFILE_DIRS =
# The MSCFILE_DIRS tag can be used to specify one or more directories that
# contain msc files that are included in the documentation (see the \mscfile
# command).
MSCFILE_DIRS =
MSCFILE_DIRS =
# The DIAFILE_DIRS tag can be used to specify one or more directories that
# contain dia files that are included in the documentation (see the \diafile
# command).
DIAFILE_DIRS =
DIAFILE_DIRS =
# When using plantuml, the PLANTUML_JAR_PATH tag should be used to specify the
# path where java can find the plantuml.jar file. If left blank, it is assumed
@ -2421,17 +2421,17 @@ DIAFILE_DIRS =
# generate a warning when it encounters a \startuml command in this case and
# will not generate output for the diagram.
PLANTUML_JAR_PATH =
PLANTUML_JAR_PATH =
# When using plantuml, the PLANTUML_CFG_FILE tag can be used to specify a
# configuration file for plantuml.
PLANTUML_CFG_FILE =
PLANTUML_CFG_FILE =
# When using plantuml, the specified paths are searched for files specified by
# the !include statement in a plantuml block.
PLANTUML_INCLUDE_PATH =
PLANTUML_INCLUDE_PATH =
# The DOT_GRAPH_MAX_NODES tag can be used to set the maximum number of nodes
# that will be shown in the graph. If the number of nodes in a graph becomes

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"
CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g
CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG
LDFLAGS := -lm
$(TARGET): $(OBJS) Makefile
$(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS)
doc: $(SRCS) Makefile
doc: $(SRCS) Makefile Doxyfile
doxygen
format: $(SRCS) $(HDRS) Makefile
@ -38,7 +38,7 @@ test: $(OBJS) $(TESTS) Makefile
.PHONY: clean
clean:
$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ *~
$(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~
repl:
$(TARGET) -p 2> psse.log

8
lisp/defun.lisp
View file

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

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

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.
*/
struct cons_pointer make_integer( long int value );
struct cons_pointer make_integer( int64_t value );
#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.
*/
struct cons_pointer
lisp_add( struct stack_frame *frame, struct cons_pointer env );
lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Multiply an indefinite number of numbers together
@ -32,7 +33,9 @@ extern "C" {
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_multiply( struct stack_frame *frame, struct cons_pointer env );
lisp_multiply( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Subtract one number from another.
@ -41,7 +44,9 @@ extern "C" {
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_subtract( struct stack_frame *frame, struct cons_pointer env );
lisp_subtract( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
/**
* Divide one number by another.
@ -50,7 +55,8 @@ extern "C" {
* @return a pointer to an integer or real.
*/
struct cons_pointer
lisp_divide( struct stack_frame *frame, struct cons_pointer env );
lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
#ifdef __cplusplus
}

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

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

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

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

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

@ -19,7 +19,7 @@
* 4294967296.
*
* Note that this means the total number of addressable cons cells is
* 1.8e19, each of 20 bytes; or 3e20 bytes in total; and there are
* 1.8e19, each of 20 bytes; or 3e20 bytes in total; and there are
* up to a maximum of 4e9 of heap space objects, each of potentially
* 4e9 bytes. So we're talking about a potential total of 8e100 bytes
* of addressable memory, which is only slightly more than the
@ -38,7 +38,7 @@ struct cons_page {
};
/**
* The (global) pointer to the (global) freelist. Not sure whether this ultimately
* The (global) pointer to the (global) freelist. Not sure whether this ultimately
* belongs in this file.
*/
extern struct cons_pointer freelist;

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

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

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

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

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,
cell_b->payload.string.cdr )
|| ( end_of_string( cell_a->payload.string.cdr )
&& end_of_string( cell_b->payload.string.
cdr ) ) );
&& end_of_string( cell_b->payload.
string.cdr ) ) );
break;
case INTEGERTV:
result =

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

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

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

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

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

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

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

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

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.
*/
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

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

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.
*/
#define VERSION "0.0.3"
#define VERSION "0.0.4"

54
unit-tests/add.sh
View file

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

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

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.