diff --git a/.gitignore b/.gitignore index b428e03..ec1281e 100644 --- a/.gitignore +++ b/.gitignore @@ -32,3 +32,7 @@ log* utils_src/readprintwc/out *.dump + +*.bak + +src/io/fopen diff --git a/Doxyfile b/Doxyfile index 955cb32..e283f9a 100644 --- a/Doxyfile +++ b/Doxyfile @@ -135,7 +135,7 @@ ABBREVIATE_BRIEF = "The $name class" \ # description. # The default value is: NO. -ALWAYS_DETAILED_SEC = NO +ALWAYS_DETAILED_SEC = YES # If the INLINE_INHERITED_MEMB tag is set to YES, doxygen will show all # inherited members of a class in the documentation of that class as if those @@ -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 = src/ # 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 @@ -187,7 +187,7 @@ SHORT_NAMES = NO # description.) # The default value is: NO. -JAVADOC_AUTOBRIEF = NO +JAVADOC_AUTOBRIEF = YES # If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first # line (until the first dot) of a Qt-style comment as the brief description. If @@ -397,7 +397,7 @@ INLINE_GROUPED_CLASSES = NO # Man pages) or section (for LaTeX and RTF). # The default value is: NO. -INLINE_SIMPLE_STRUCTS = NO +INLINE_SIMPLE_STRUCTS = YES # When TYPEDEF_HIDES_STRUCT tag is enabled, a typedef of a struct, union, or # enum is documented as struct, union, or enum with the name of the typedef. So @@ -578,7 +578,7 @@ SORT_MEMBER_DOCS = YES # this will also influence the order of the classes in the class list. # The default value is: NO. -SORT_BRIEF_DOCS = NO +SORT_BRIEF_DOCS = YES # If the SORT_MEMBERS_CTORS_1ST tag is set to YES then doxygen will sort the # (brief and detailed) documentation of class members so that constructors and @@ -790,7 +790,7 @@ WARN_LOGFILE = doxy.log # spaces. See also FILE_PATTERNS and EXTENSION_MAPPING # Note: If this tag is empty the current directory is searched. -INPUT = src src/arith src/memory src/ops +INPUT = src # 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 @@ -864,7 +864,7 @@ FILE_PATTERNS = *.c \ # be searched for input files as well. # The default value is: NO. -RECURSIVE = NO +RECURSIVE = YES # The EXCLUDE tag can be used to specify files and/or directories that should be # excluded from the INPUT source files. This way you can easily exclude a diff --git a/Makefile b/Makefile index c368d50..c4c4ef3 100644 --- a/Makefile +++ b/Makefile @@ -15,13 +15,13 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ -d0 -di1 -nfc1 -i4 -ip0 -l75 -lp -npcs \ -npsl -nsc -nsob -nss -nut -prs -l79 -ts2 -VERSION := "0.0.2" - CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG -LDFLAGS := -lm +LDFLAGS := -lm -lcurl + +all: $(TARGET) $(TARGET): $(OBJS) Makefile - $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) + $(CC) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) doc: $(SRCS) Makefile Doxyfile doxygen diff --git a/hi b/hi new file mode 100644 index 0000000..cf57f2a --- /dev/null +++ b/hi @@ -0,0 +1 @@ +Hello, this is used by `slurp.sh` test, please do not remove. diff --git a/lisp/expt.lisp b/lisp/expt.lisp new file mode 100644 index 0000000..8b32252 --- /dev/null +++ b/lisp/expt.lisp @@ -0,0 +1,8 @@ +(set! expt (lambda + (n x) + "Return the value of `n` raised to the `x`th power." + (cond + ((= x 1) n) + (t (* n (expt n (- x 1))))))) + +(inspect (expt 2 60)) diff --git a/lisp/fact.lisp b/lisp/fact.lisp index de1f12b..86d452a 100644 --- a/lisp/fact.lisp +++ b/lisp/fact.lisp @@ -1,6 +1,7 @@ (set! fact (lambda (n) + "Compute the factorial of `n`, expected to be an integer." (cond ((= n 1) 1) (t (* n (fact (- n 1))))))) -(fact 20) +(fact 1000) diff --git a/lisp/not-working-yet.lisp b/lisp/not-working-yet.lisp new file mode 100644 index 0000000..0f3a8c2 --- /dev/null +++ b/lisp/not-working-yet.lisp @@ -0,0 +1,6 @@ +(set! or (lambda values + "True if any of `values` are non-nil." + (cond + ((nil? values) nil) + ((car values) t) + (t (eval (cons 'or (cdr values))))))) diff --git a/lisp/scratchpad.lisp b/lisp/scratchpad.lisp new file mode 100644 index 0000000..0474099 --- /dev/null +++ b/lisp/scratchpad.lisp @@ -0,0 +1,48 @@ +(set! i + (+ + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000)) + +(set! j (+ i i i i i i i i i i)) + +(set! k (+ j j j j j j j j j j)) + +(set! l (+ k k k k k k k k k k)) + +(set! m (+ l l l l l l l l l l)) + +(set! n (+ m m m m m m m m m m)) + +(set! o (+ n n n n n n n n n n)) + +(set! p (+ o o o o o o o o o o)) + +(set! q (+ p p p p p p p p p p)) + +(set! r (+ q q q q q q q q q q)) + +(set! s (+ r r r r r r r r r r)) + +(set! t (+ s s s s s s s s s s)) + +(set! u (+ t t t t t t t t t t)) + +(set! v (+ u u u u u u u u u u)) + +(set! x (+ v v v v v v v v v v)) + +(set! y (+ x x x x x x x x x x)) + +"we're OK to here: 10^36, which is below the 2^120 barrier so represented as two cells" +(inspect (set! z (+ y y y y y y y y y y))) + +"This blows up: 10^37, which is a three cell bignum." +(inspect (set! final (+ z z z z z z z z z z))) diff --git a/lisp/scratchpad2.lisp b/lisp/scratchpad2.lisp new file mode 100644 index 0000000..65f7aca --- /dev/null +++ b/lisp/scratchpad2.lisp @@ -0,0 +1,85 @@ +"This demonstrates that although the print representation of three cell bignums blows up, the internal representation is sane" + +"We start by adding 8 copies of 2^60 - i.e. the first two-cell integer" + +(set! a + (+ + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976)) + +"Then repeatedly add eight copies of the previous generation" + +(set! b (+ a a a a a a a a)) + +(set! c (+ b b b b b b b b)) + +(set! d (+ c c c c c c c c)) + +(set! e (+ d d d d d d d d)) + +(set! f (+ e e e e e e e e)) + +(set! g (+ f f f f f f f f)) + +(set! h (+ g g g g g g g g)) + +(set! i (+ h h h h h h h h)) + +(set! j (+ i i i i i i i i)) + +(set! k (+ j j j j j j j j)) + +(set! l (+ k k k k k k k k)) + +(set! m (+ l l l l l l l l)) + +(set! n (+ m m m m m m m m)) + +(set! o (+ n n n n n n n n)) + +"p" +(set! p (+ o o o o o o o o)) + +"q" +(set! q (+ p p p p p p p p)) + +"r" +(set! r (+ q q q q q q q q)) + +"s" +(inspect + (set! s (+ r r r r r r r r))) + +"t - first three cell integer. Printing blows up here" +(inspect + (set! t (+ s s s s s s s s))) + +"u" +(inspect + (set! u (+ t t t t t t t t))) + +"v" +(inspect + (set! v (+ u u u u u u u u))) + +"w" +(inspect + (set! w (+ v v v v v v v v))) + +(inspect + (set! x (+ w w w w w w w w))) + +(inspect + (set! y (+ x x x x x x x x))) + +(inspect + (set! z (+ y y y y y y y y))) + +(inspect + (set! final (+ z z z z z z z z))) diff --git a/lisp/slurp.lisp b/lisp/slurp.lisp new file mode 100644 index 0000000..e927bcb --- /dev/null +++ b/lisp/slurp.lisp @@ -0,0 +1 @@ +(slurp (set! f (open "http://www.journeyman.cc/"))) diff --git a/lisp/types.lisp b/lisp/types.lisp new file mode 100644 index 0000000..7f7bf8c --- /dev/null +++ b/lisp/types.lisp @@ -0,0 +1,17 @@ +(set! cons? (lambda (o) "True if o is a cons cell." (= (type o) "CONS") ) ) +(set! exception? (lambda (o) "True if o is an exception." (= (type o) "EXEP"))) +(set! free? (lambda (o) "Trus if o is a free cell - this should be impossible!" (= (type o) "FREE"))) +(set! function? (lambda (o) "True if o is a compiled function." (= (type o) "EXEP"))) +(set! integer? (lambda (o) "True if o is an integer." (= (type o) "INTR"))) +(set! lambda? (lambda (o) "True if o is an interpreted (source) function." (= (type o) "LMDA"))) +(set! nil? (lambda (o) "True if o is the canonical nil value." (= (type o) "NIL "))) +(set! nlambda? (lambda (o) "True if o is an interpreted (source) special form." (= (type o) "NLMD"))) +(set! rational? (lambda (o) "True if o is an rational number." (= (type o) "RTIO"))) +(set! read? (lambda (o) "True if o is a read stream." (= (type o) "READ") ) ) +(set! real? (lambda (o) "True if o is an real number." (= (type o) "REAL"))) +(set! special? (lambda (o) "True if o is a compiled special form." (= (type o) "SPFM") ) ) +(set! string? (lambda (o) "True if o is a string." (= (type o) "STRG") ) ) +(set! symbol? (lambda (o) "True if o is a symbol." (= (type o) "SYMB") ) ) +(set! true? (lambda (o) "True if o is the canonical true value." (= (type o) "TRUE") ) ) +(set! write? (lambda (o) "True if o is a write stream." (= (type o) "WRIT") ) ) + diff --git a/notes/bignums.md b/notes/bignums.md new file mode 100644 index 0000000..f77653c --- /dev/null +++ b/notes/bignums.md @@ -0,0 +1,7 @@ +# All integers are potentially bignums + +Each integer comprises at least one cell of type INTR, holding a signed 64 bit integer with a value in the range 0 ... MAX-INTEGER, where the actual value of MAX-INTEGER does not need to be the same as the C language LONG\_MAX, provided that it is less than this. It seems to me that a convenient number would be the largest number less than LONG\_MAX which has all bits set + +LONG\_MAX is 0x7FFFFFFFFFFFFFFF, so the number we're looking for is 0x0FFFFFFFFFFFFFFF, which is 1,152,921,504,606,846,975, which is 2^60 - 1. This means we can use bit masking with 0xFFFFFFFFFFFFFFF to extract the part of **int64_t** which will fit in a single cell. + +It also means that if we multiply two **int64_t**s into an **__int128_t**, we can then right-shift by 60 places to get the carry. diff --git a/notes/mad-software.md b/notes/mad-software.md new file mode 100644 index 0000000..bbe8092 --- /dev/null +++ b/notes/mad-software.md @@ -0,0 +1,75 @@ +# Mad software + +I was listening to [Eric Normand's podcast](https://lispcast.com/tension-between-data-and-entity/) this morning, as I was making breakfast and tidying my room; he was talking about semantics and data. It started a train of thought which I shall try to unroll. + +I have blogged a lot in the past about madness and about software, but I don't think I've ever blogged about madness and software in the same essay. But the reasons I'm mad and the reasons I'm (sometimes) very good at software are related; both have their roots in autism and dyslexia, or, to put it differently, how my brain is wired. + +I first wrote about [post scarcity software](https://blog.journeyman.cc/2006/02/post-scarcity-software.html) thirteen years ago. It was a thought about how software environments should be designed if were weren't held back by the cruft of the past, by tradition and by a lack, frankly, of anything much in the way of new creative thought. And seeing that the core of the system I described is a Lisp, which is to say it builds on a software architecture which is exactly as old as I am, perhaps it is infected by my take on tradition and my own lack of creativity, but let's, for the purposes of this essay, assume not. + +I started actually writing the [post scarcity software environment](https://github.com/simon-brooke/post-scarcity) on the second of January 2017, which is to say two years ago. It's been an extremely low priority task, because I don't have enough faith in either my vision or my skill to think that it will ever be of use to anyone. Nevertheless, it does now actually work, in as much as you can write software in it. It's not at all easy yet, and I wouldn't recommend anyone try, but you can check out the master branch from Github, compile it, and it works. + +As my mental health has deteriorated, I have been working on it more over the past couple of months, partly because I have lost faith in my ability to deliver the more practical projects I've been working on, and partly because doing something which is genuinely intellectually hard helps subdue the chaos in my mind. + +Having said that, it is hard and I am not sharp, and so progress is slow. I started work on big number arithmetic a three weeks ago, and where I'm up to at this point is: + +* addition seems to work up to at least the second bignum boundary; +* multiplication doesn't work beyond the first bignum boundary; +* subraction doesn't work, and turns out not to be as easy as just inverting addition; +* division sort of trivially works, but only in the sense that we can create a rational number out of arbitrary bignums; +* reading works beyond the first bignum boundary, but not up to the second (because multiplication doesn't work); +* printing doesn't work beyond the first bignum boundary. + +I knew bignums were going to be a challenge, and I could have studied other people's bignum code and have consciously chosen not to do so; but this is not fast progress. + +(I should point out that in those three weeks I've also done four days of customer work, which is .Net and boring but it's done, spent two days seeing my sister, spent two days so depressed I didn't actually do anything at all, and done a bit or practical work around the croft. But still!) + +In a sense, it wasn't expected to be. Writing the underpinnings of a software environment which is conceptually without limits has challenge after challenge after challenge. + +But there are ideas in post scarcity which may have wider utility than this mad idea in itself. Layering homogeneities and regularities onto Clojure maps might - perhaps would - make a useful library, might would make a very useful component for exactly the sort of data wrangling Eric Normand was talking about. Yes, you can use a map - raw data soup - to represent a company. But if this map is a member of a homogeneity, 'Companies', then we know every member of it has employees, and that every employee has a salary and an email address. Regularities and homogeneities form the building blocks of APIs; to use the example Eric discussed in his podcast, the salary is the property of the employee, but the payroll is a property of the company. So in post scarcity, you'd get the payroll figure for a company by using a method on the 'Companies' homogeneity. How it computes that value is part of the general doctrine of **'Don't Know, Don't Care'**: the principal that people writing software at any layer in the system do not need to know, and should not need to care, about how things are implemented in the layers below them. + + + +So, the user needing to find the payroll value would enter something like this: + +``` + (with ((companies . ::shared:pool:companies) + (acme . companies:acme-widgets)) + (companies:methods:payroll acme)) +``` + +In practice, in post scarcity notation, the payroll method probably looks something like this: + +``` + (lambda (company) + (reduce + (map ::shared:pool:employees:methods:salary (:employees company)))) +``` + +There are issues that I haven't resolved yet about the mutability of regularities and homogeneities; obviously, in order to provide multi-user visibility of current values of shared data, some regularities must be mutable. But mutability has potentially very serious perfomance issues for the hypercube architecture, so I think that in general they should not be. + +However, that's detail, and not what I'm trying to talk about here. + +What I'm trying to talk about here is the fact that if I were confident that these ideas were any good, and that I had the ability to persuade others that they were any good, it would make far more sense to implement them in Clojure and promote them as a library. + +But the problem with depression is that you cannot evaluate whether your ideas are any good. The black dog tells you you're shit, and that your ideas are shit, and that you don't really know enough to be worth listening to, and that you're an old tramp who lives in a hut in the woods, and probably smells, and that in any case interaction with other people quickly makes you shaky and confused, and that you can never get your act together, and you never finish anything. + +And all that is objectively true, and I know that it is true. But I also know that I can (or at least have in the past been able to) build really good software, and that I can (or have been able, in the past, to) present ideas really well. + +These two collections of statements about me are both true at the same time. But the difference is that I believe the first and I don't believe the second. + +And behind all this is the fact that bignum arithmetic is a solved problem. I could dig out the SBCL source code and crib from that. I am bashing my head against bignum arithmetic and trying to solve it myself, not because it's the most efficient way to produce good code quickly, but because what I'm really trying to do is just distract myself and waste time while I can get on with dying. + +And the reason beyond that that I'm working on a software system I know I'll never finish, which is designed to run on computers which don't even exist yet - and although I'm very confident that enormously parallel hardware will be used in future, I'm not at all sure it will look anything like what I'm envisaging - the reason I'm building this mad software is that, because it will never be finished, no-one will ever use it except me, and no-one will say how crap it is and how easily it could have been done better. + +Because the other thing that I'm doing in writing this stuff, apart from distracting from the swirling chaos and rage in my head, apart from waiting to die, the other thing I'm doing is trying to give myself a feeling of mastery, of competence, of ability to face problems and solve them. And, to an extent, it works. But I have so little confidence that I actually have that mastery, that competence, that I don't want to expose it to criticism. I don't want my few fragile rags of self worth stripped away. + +And so I work, and work, and work at something which is so arcane, so obscure, so damned pointless that no-one will ever use it. + +Not because I'm even enjoying it, but just to burn the time. + +This is mad. + +I am mad. + +I hate, hate, hate being mad. + +Postscript: just writing this essay has made me tearful, headachey, sick, shaky. It's very hard to face up to the irrationalities and self-deceptions in one's own behaviour. diff --git a/src/arith/bignum.c b/src/arith/bignum.c deleted file mode 100644 index a21a7df..0000000 --- a/src/arith/bignum.c +++ /dev/null @@ -1,14 +0,0 @@ -/* - * bignum.c - * - * Allocation of and operations on arbitrary precision integers. - * - * (c) 2018 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -/* - * Bignums generally follow Knuth, vol 2, 4.3. The word size is 64 bits, - * and words are stored in individual cons-space objects, comprising the - * word itself and a pointer to the next word in the number. - */ diff --git a/src/arith/bignum.h b/src/arith/bignum.h deleted file mode 100644 index 05c9073..0000000 --- a/src/arith/bignum.h +++ /dev/null @@ -1,16 +0,0 @@ -/** - * bignum.h - * - * functions for bignum cells. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __bignum_h -#define __bignum_h - - - -#endif diff --git a/src/arith/integer.c b/src/arith/integer.c index 5239746..1195c53 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -8,40 +8,384 @@ */ #define _GNU_SOURCE +#include #include #include +#include +/* safe_iop, as available in the Ubuntu repository, is this one: + * https://code.google.com/archive/p/safe-iop/wikis/README.wiki + * which is installed as `libsafe-iop-dev`. There is an alternate + * implementation here: https://github.com/redpig/safe-iop/ + * which shares the same version number but is not compatible. */ +#include +/* + * wide characters + */ +#include +#include #include "conspage.h" #include "consspaceobject.h" #include "debug.h" +#include "equal.h" +#include "lispops.h" +#include "peano.h" /** - * return the numeric value of this cell, as a C primitive double, not - * as a cons-space object. Cell may in principle be any kind of number, - * but only integers and reals are so far implemented. + * hexadecimal digits for printing numbers. */ -long double numeric_value( struct cons_pointer pointer ) { - long double result = NAN; - struct cons_space_object *cell = &pointer2cell( pointer ); +const char *hex_digits = "0123456789ABCDEF"; - if ( integerp( pointer ) ) { - result = cell->payload.integer.value * 1.0; - } else if ( realp( pointer ) ) { - result = cell->payload.real.value; +/* + * Doctrine from here on in is that ALL integers are bignums, it's just + * that integers less than 65 bits are bignums of one cell only. + */ + +/** + * Allocate an integer cell representing this `value` and return a cons_pointer to it. + * @param value an integer value; + * @param more `NIL`, or a pointer to the more significant cell(s) of this number. + * *NOTE* that if `more` is not `NIL`, `value` *must not* exceed `MAX_INTEGER`. + */ +struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { + struct cons_pointer result = NIL; + debug_print( L"Entering make_integer\n", DEBUG_ALLOC ); + + if ( integerp( more ) || nilp( more ) ) { + result = allocate_cell( INTEGERTAG ); + struct cons_space_object *cell = &pointer2cell( result ); + cell->payload.integer.value = value; + cell->payload.integer.more = more; + + } + + debug_print( L"make_integer: returning\n", DEBUG_ALLOC ); + debug_dump_object( result, DEBUG_ALLOC ); + return result; +} + +/** + * Low level integer arithmetic, do not use elsewhere. + * + * @param c a pointer to a cell, assumed to be an integer cell; + * @param op a character representing the operation: expectedto be either + * '+' or '*'; behaviour with other values is undefined. + * @param is_first_cell true if this is the first cell in a bignum + * chain, else false. + * \see multiply_integers + * \see add_integers + */ +__int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { + long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value; + + long int carry = is_first_cell ? 0 : ( MAX_INTEGER + 1 ); + + __int128_t result = ( __int128_t ) integerp( c ) ? + ( val == 0 ) ? carry : val : op == '*' ? 1 : 0; + debug_printf( DEBUG_ARITH, + L"cell_value: raw value is %ld, is_first_cell = %s; %4.4s; returning ", + val, is_first_cell ? "true" : "false", + pointer2cell( c ).tag.bytes ); + debug_print_128bit( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + return result; +} + +/** + * Overwrite the value field of the integer indicated by `new` with + * the least significant 60 bits of `val`, and return the more significant + * bits (if any) right-shifted by 60 places. Destructive, primitive, do not + * use in any context except primitive operations on integers. + * + * @param val the value to represent; + * @param less_significant the less significant words of this bignum, if any, + * else NIL; + * @param new a newly created integer, which will be destructively changed. + * @return carry, if any, else 0. + */ +__int128_t int128_to_integer( __int128_t val, + struct cons_pointer less_significant, + struct cons_pointer new ) { + struct cons_pointer cursor = NIL; + __int128_t carry = 0; + + if ( MAX_INTEGER >= val ) { + carry = 0; + } else { + carry = val >> 60; + debug_printf( DEBUG_ARITH, + L"int128_to_integer: 64 bit overflow; setting carry to %ld\n", + ( int64_t ) carry ); + val &= MAX_INTEGER; + } + + struct cons_space_object *newc = &pointer2cell( new ); + newc->payload.integer.value = val; + + if ( integerp( less_significant ) ) { + struct cons_space_object *lsc = &pointer2cell( less_significant ); + inc_ref( new ); + lsc->payload.integer.more = new; + } + + return carry; +} + +struct cons_pointer make_integer_128( __int128_t val, + struct cons_pointer less_significant ) { + struct cons_pointer result = NIL; + + do { + if ( MAX_INTEGER >= val ) { + result = make_integer( ( long int ) val, less_significant ); + } else { + less_significant = + make_integer( ( long int ) val & MAX_INTEGER, + less_significant ); + val = val >> 60; + } + + } while ( nilp( result ) ); + + return result; +} + +/** + * Return a pointer to an integer representing the sum of the integers + * pointed to by `a` and `b`. If either isn't an integer, will return nil. + */ +struct cons_pointer add_integers( struct cons_pointer a, + struct cons_pointer b ) { + struct cons_pointer result = NIL; + struct cons_pointer cursor = NIL; + + debug_print( L"add_integers: a = ", DEBUG_ARITH ); + debug_print_object( a, DEBUG_ARITH ); + debug_print( L"; b = ", DEBUG_ARITH ); + debug_print_object( b, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + __int128_t carry = 0; + bool is_first_cell = true; + + if ( integerp( a ) && integerp( b ) ) { + debug_print( L"add_integers: \n", DEBUG_ARITH ); + debug_dump_object( a, DEBUG_ARITH ); + debug_print( L" plus \n", DEBUG_ARITH ); + debug_dump_object( b, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { + __int128_t av = cell_value( a, '+', is_first_cell ); + __int128_t bv = cell_value( b, '+', is_first_cell ); + __int128_t rv = av + bv + carry; + + debug_print( L"add_integers: av = ", DEBUG_ARITH ); + debug_print_128bit( av, DEBUG_ARITH ); + debug_print( L"; bv = ", DEBUG_ARITH ); + debug_print_128bit( bv, DEBUG_ARITH ); + debug_print( L"; carry = ", DEBUG_ARITH ); + debug_print_128bit( carry, DEBUG_ARITH ); + debug_print( L"; rv = ", DEBUG_ARITH ); + debug_print_128bit( rv, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); + + struct cons_pointer new = make_integer( 0, NIL ); + carry = int128_to_integer( rv, cursor, new ); + cursor = new; + + if ( nilp( result ) ) { + result = cursor; + } + + a = pointer2cell( a ).payload.integer.more; + b = pointer2cell( b ).payload.integer.more; + is_first_cell = false; + } + } + + debug_print( L"add_integers returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + return result; +} + +struct cons_pointer base_partial( int depth ) { + struct cons_pointer result = NIL; + + for ( int i = 0; i < depth; i++ ) { + result = make_integer( 0, result ); } return result; } /** - * Allocate an integer cell representing this value and return a cons pointer to it. + * Return a pointer to an integer representing the product of the integers + * pointed to by `a` and `b`. If either isn't an integer, will return nil. + * \todo it is MUCH more complicated than this! + * + * @param a an integer; + * @param b an integer. */ -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; +struct cons_pointer multiply_integers( struct cons_pointer a, + struct cons_pointer b ) { + struct cons_pointer result = NIL; + bool neg = is_negative( a ) != is_negative( b ); + bool is_first_b = true; + int oom = -1; - debug_dump_object( result, DEBUG_ARITH ); + debug_print( L"multiply_integers: a = ", DEBUG_ARITH ); + debug_print_object( a, DEBUG_ARITH ); + debug_print( L"; b = ", DEBUG_ARITH ); + debug_print_object( b, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + if ( integerp( a ) && integerp( b ) ) { + while ( !nilp( b ) ) { + bool is_first_d = true; + struct cons_pointer d = a; + struct cons_pointer partial = base_partial( ++oom ); + __int128_t carry = 0; + + while ( !nilp( d ) || carry != 0 ) { + partial = make_integer( 0, partial ); + struct cons_pointer new = NIL; + __int128_t dv = cell_value( d, '+', is_first_d ); + __int128_t bv = cell_value( b, '+', is_first_b ); + + __int128_t rv = ( dv * bv ) + carry; + + debug_print( L"multiply_integers: d = ", DEBUG_ARITH ); + debug_print_object( d, DEBUG_ARITH ); + debug_print( L"; dv = ", DEBUG_ARITH ); + debug_print_128bit( dv, DEBUG_ARITH ); + debug_print( L"; bv = ", DEBUG_ARITH ); + debug_print_128bit( bv, DEBUG_ARITH ); + debug_print( L"; carry = ", DEBUG_ARITH ); + debug_print_128bit( carry, DEBUG_ARITH ); + debug_print( L"; rv = ", DEBUG_ARITH ); + debug_print_128bit( rv, DEBUG_ARITH ); + debug_print( L"; acc = ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_print( L"; partial = ", DEBUG_ARITH ); + debug_print_object( partial, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); + + new = make_integer_128( rv, base_partial( oom ) ); + + if ( zerop( partial ) ) { + partial = new; + } else { + partial = add_integers( partial, new ); + } + + d = integerp( d ) ? pointer2cell( d ).payload.integer. + more : NIL; + is_first_d = false; + } + + if ( nilp( result ) || zerop( result ) ) { + result = partial; + } else { + struct cons_pointer old = result; + result = add_integers( partial, result ); + //if (!eq(result, old)) dec_ref(old); + //if (!eq(result, partial)) dec_ref(partial); + } + b = pointer2cell( b ).payload.integer.more; + is_first_b = false; + } + } + + debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + return result; +} + +/** + * don't use; private to integer_to_string, and somewaht dodgy. + */ +struct cons_pointer integer_to_string_add_digit( int digit, int digits, + struct cons_pointer tail ) { + wint_t character = btowc( hex_digits[digit] ); + return ( digits % 3 == 0 ) ? + make_string( L',', make_string( character, + tail ) ) : + make_string( character, tail ); +} + +/** + * The general principle of printing a bignum is that you print the least + * significant digit in whatever base you're dealing with, divide through + * by the base, print the next, and carry on until you've none left. + * Obviously, that means you print from right to left. Given that we build + * strings from right to left, 'printing' an integer to a lisp string + * would seem reasonably easy. The problem is when you jump from one integer + * object to the next. 64 bit integers don't align with decimal numbers, so + * when we get to the last digit from one integer cell, we have potentially + * to be looking to the next. H'mmmm. + */ +/* + * \todo this blows up when printing three-cell integers, but works fine + * for two-cell. What's happening is that when we cross the barrier we + * SHOULD print 2^120, but what we actually print is 2^117. H'mmm. + */ +struct cons_pointer integer_to_string( struct cons_pointer int_pointer, + int base ) { + struct cons_pointer result = NIL; + struct cons_space_object integer = pointer2cell( int_pointer ); + __int128_t accumulator = llabs( integer.payload.integer.value ); + bool is_negative = integer.payload.integer.value < 0; + int digits = 0; + + if ( accumulator == 0 && nilp( integer.payload.integer.more ) ) { + result = c_string_to_lisp_string( L"0" ); + } else { + while ( accumulator > 0 || !nilp( integer.payload.integer.more ) ) { + if ( !nilp( integer.payload.integer.more ) ) { + integer = pointer2cell( integer.payload.integer.more ); + accumulator += integer.payload.integer.value; + debug_print + ( L"integer_to_string: crossing cell boundary, accumulator is: ", + DEBUG_IO ); + debug_print_128bit( accumulator, DEBUG_IO ); + debug_println( DEBUG_IO ); + } + + do { + int offset = ( int ) ( accumulator % base ); + debug_printf( DEBUG_IO, + L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", + offset, hex_digits[offset] ); + debug_print_128bit( accumulator, DEBUG_IO ); + debug_print( L"; result is: ", DEBUG_IO ); + debug_print_object( result, DEBUG_IO ); + debug_println( DEBUG_IO ); + + result = + integer_to_string_add_digit( offset, ++digits, result ); + accumulator = accumulator / base; + } while ( accumulator > base ); + } + + if ( stringp( result ) + && pointer2cell( result ).payload.string.character == L',' ) { + /* if the number of digits in the string is divisible by 3, there will be + * an unwanted comma on the front. */ + struct cons_pointer tmp = result; + result = pointer2cell( result ).payload.string.cdr; + //dec_ref( tmp ); + } + + if ( is_negative ) { + result = make_string( L'-', result ); + } + } return result; } diff --git a/src/arith/integer.h b/src/arith/integer.h index 00b94a6..117a0bf 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -1,4 +1,4 @@ -/** +/* * integer.h * * functions for integer cells. @@ -11,11 +11,15 @@ #ifndef __integer_h #define __integer_h -long double numeric_value( struct cons_pointer pointer ); +struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); -/** - * Allocate an integer cell representing this value and return a cons pointer to it. - */ -struct cons_pointer make_integer( int64_t value ); +struct cons_pointer add_integers( struct cons_pointer a, + struct cons_pointer b ); + +struct cons_pointer multiply_integers( struct cons_pointer a, + struct cons_pointer b ); + +struct cons_pointer integer_to_string( struct cons_pointer int_pointer, + int base ); #endif diff --git a/src/arith/peano.c b/src/arith/peano.c index a52f314..8e4cb43 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -21,6 +21,7 @@ #include "integer.h" #include "intern.h" #include "lispops.h" +#include "peano.h" #include "print.h" #include "ratio.h" #include "read.h" @@ -34,14 +35,23 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, struct cons_pointer arg2 ); - +/** + * return true if this `arg` points to a number whose value is zero. + */ 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; + case INTEGERTV:{ + do { + debug_print( L"zerop: ", DEBUG_ARITH ); + debug_dump_object( arg, DEBUG_ARITH ); + result = + ( pointer2cell( arg ).payload.integer.value == 0 ); + arg = pointer2cell( arg ).payload.integer.more; + } while ( result && integerp( arg ) ); + } break; case RATIOTV: result = zerop( cell.payload.ratio.dividend ); @@ -55,29 +65,89 @@ bool zerop( struct cons_pointer arg ) { } /** - * 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. + * does this `arg` point to a negative number? */ -long double to_long_double( struct cons_pointer arg ) { - long double result = 0; /* not a number, as a long double */ +bool is_negative( struct cons_pointer arg ) { + bool result = false; struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { case INTEGERTV: - result = ( double ) cell.payload.integer.value; + result = cell.payload.integer.value < 0; break; case RATIOTV: - { - struct cons_space_object dividend = - pointer2cell( cell.payload.ratio.dividend ); - struct cons_space_object divisor = - pointer2cell( cell.payload.ratio.divisor ); + result = is_negative( cell.payload.ratio.dividend ); + break; + case REALTV: + result = ( cell.payload.real.value < 0 ); + break; + } + return result; +} + +struct cons_pointer absolute( struct cons_pointer frame_pointer, + struct cons_pointer arg ) { + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( arg ); + + if ( is_negative( arg ) ) { + switch ( cell.tag.value ) { + case INTEGERTV: result = - ( long double ) dividend.payload.integer.value / - divisor.payload.integer.value; - } + make_integer( llabs( cell.payload.integer.value ), + cell.payload.integer.more ); + break; + case RATIOTV: + result = make_ratio( frame_pointer, + absolute( frame_pointer, + cell.payload.ratio.dividend ), + cell.payload.ratio.divisor ); + break; + case REALTV: + result = make_real( 0 - cell.payload.real.value ); + break; + } + } + + return result; +} + +/** + * Return the closest possible `binary64` representation to the value of + * this `arg`, expected to be an integer, ratio or real, or `NAN` if `arg` + * is not any of these. + * + * @arg a pointer to an integer, ratio or real. + * + * \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; + struct cons_space_object cell = pointer2cell( arg ); + + switch ( cell.tag.value ) { + case INTEGERTV: + // obviously, this doesn't work for bignums + result = ( long double ) cell.payload.integer.value; + // sadly, this doesn't work at all. +// result += 1.0; +// for (bool is_first = false; integerp(arg); is_first = true) { +// debug_printf(DEBUG_ARITH, L"to_long_double: accumulator = %lf, arg = ", result); +// debug_dump_object(arg, DEBUG_ARITH); +// if (!is_first) { +// result *= (long double)(MAX_INTEGER + 1); +// } +// result *= (long double)(cell.payload.integer.value); +// arg = cell.payload.integer.more; +// cell = pointer2cell( arg ); +// } + break; + case RATIOTV: + result = to_long_double( cell.payload.ratio.dividend ) / + to_long_double( cell.payload.ratio.divisor ); break; case REALTV: result = cell.payload.real.value; @@ -96,7 +166,13 @@ long double to_long_double( struct cons_pointer arg ) { /** - * TODO: cannot throw an exception out of here, which is a problem + * Return the closest possible `int64_t` representation to the value of + * this `arg`, expected to be an integer, ratio or real, or `NAN` if `arg` + * is not any of these. + * + * @arg a pointer to an integer, ratio or real. + * + * \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. */ @@ -105,6 +181,9 @@ int64_t to_long_int( struct cons_pointer arg ) { struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { case INTEGERTV: + /* \todo if (integerp(cell.payload.integer.more)) { + * throw an exception! + * } */ result = cell.payload.integer.value; break; case RATIOTV: @@ -119,9 +198,25 @@ int64_t to_long_int( struct cons_pointer arg ) { /** -* return a cons_pointer indicating a number which is the sum of -* the numbers indicated by `arg1` and `arg2`. -*/ + * Function: calculate the absolute value of a number. + * + * (absolute arg) + * + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return the absolute value of the number represented by the first + * argument, or NIL if it was not a number. + */ +struct cons_pointer lisp_absolute( struct stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return absolute( frame_pointer, frame->arg[0] ); +} + +/** + * 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, @@ -131,9 +226,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_space_object cell2 = pointer2cell( arg2 ); debug_print( L"add_2( arg1 = ", DEBUG_ARITH ); - debug_print_object( arg1, DEBUG_ARITH ); + debug_dump_object( arg1, DEBUG_ARITH ); debug_print( L"; arg2 = ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); + debug_dump_object( arg2, DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH ); if ( zerop( arg1 ) ) { @@ -152,8 +247,7 @@ struct cons_pointer add_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = make_integer( cell1.payload.integer.value + - cell2.payload.integer.value ); + result = add_integers( arg1, arg2 ); break; case RATIOTV: result = @@ -219,12 +313,13 @@ struct cons_pointer add_2( struct stack_frame *frame, * 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. + * @return a pointer to an integer, ratio or real. + * @exception if any argument is not a number, returns an exception. */ 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 result = make_integer( 0, NIL ); struct cons_pointer tmp; for ( int i = 0; @@ -253,9 +348,9 @@ struct cons_pointer lisp_add( struct stack_frame /** -* return a cons_pointer indicating a number which is the product of -* the numbers indicated by `arg1` and `arg2`. -*/ + * 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, @@ -268,7 +363,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, debug_print_object( arg1, DEBUG_ARITH ); debug_print( L"; arg2 = ", DEBUG_ARITH ); debug_print_object( arg2, DEBUG_ARITH ); - debug_print( L")", DEBUG_ARITH ); + debug_print( L")\n", DEBUG_ARITH ); if ( zerop( arg1 ) ) { result = arg2; @@ -285,8 +380,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = make_integer( cell1.payload.integer.value * - cell2.payload.integer.value ); + result = multiply_integers( arg1, arg2 ); break; case RATIOTV: result = @@ -299,9 +393,12 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: not a number" ), - frame_pointer ); + result = + throw_exception( make_cons + ( c_string_to_lisp_string + ( L"Cannot multiply: argument 2 is not a number: " ), + c_type( arg2 ) ), + frame_pointer ); break; } break; @@ -325,9 +422,12 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: not a number" ), - frame_pointer ); + result = + throw_exception( make_cons + ( c_string_to_lisp_string + ( L"Cannot multiply: argument 2 is not a number" ), + c_type( arg2 ) ), + frame_pointer ); } break; case REALTV: @@ -336,66 +436,68 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: not a number" ), + result = throw_exception( make_cons( c_string_to_lisp_string + ( L"Cannot multiply: argument 1 is not a number" ), + c_type( arg1 ) ), frame_pointer ); break; } } - debug_print( L" => ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L"multiply_2 returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH ); return result; } +#define multiply_one_arg(arg) {if (exceptionp(arg)){result=arg;}else{tmp = result; result = multiply_2( frame, frame_pointer, result, arg ); if ( !eq( tmp, result ) ) dec_ref( tmp );}} /** * 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. + * @return a pointer to an integer, ratio or real. + * @exception if any argument is not a number, returns an exception. */ 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 result = make_integer( 1, NIL ); 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] ); + debug_print( L"lisp_multiply: accumulator = ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_print( L"; arg = ", DEBUG_ARITH ); + debug_print_object( frame->arg[i], DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); - if ( !eq( tmp, result ) ) { - dec_ref( tmp ); - } + multiply_one_arg( frame->arg[i] ); } 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 ); - } - + multiply_one_arg( c_car( more ) ); more = c_cdr( more ); } + debug_print( L"lisp_multiply returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + return result; } /** * return a cons_pointer indicating a number which is the - * inverse of the number indicated by `arg`. + * 0 - the number indicated by `arg`. */ -struct cons_pointer inverse( struct cons_pointer frame, - struct cons_pointer arg ) { +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); @@ -404,16 +506,17 @@ struct cons_pointer inverse( struct cons_pointer frame, result = arg; break; case INTEGERTV: - result = make_integer( 0 - to_long_int( arg ) ); + result = + make_integer( 0 - cell.payload.integer.value, + cell.payload.integer.more ); break; case NILTV: result = TRUE; break; case RATIOTV: result = make_ratio( frame, - make_integer( 0 - - to_long_int( cell.payload.ratio. - dividend ) ), + negative( frame, + cell.payload.ratio.dividend ), cell.payload.ratio.divisor ); break; case REALTV: @@ -429,47 +532,65 @@ struct cons_pointer inverse( struct cons_pointer frame, /** - * Subtract one number from another. + * Function: is this number negative? + * + * * (negative? arg) + * * @param env the evaluation environment - ignored; * @param frame the stack frame. - * @return a pointer to an integer or real. + * @return T if the first argument was a negative number, or NIL if it + * was not. */ -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] ); +struct cons_pointer lisp_is_negative( struct stack_frame + *frame, + struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return is_negative( frame->arg[0] ) ? TRUE : NIL; +} - switch ( cell0.tag.value ) { + +/** + * return a cons_pointer indicating a number which is the result of + * subtracting the number indicated by `arg2` from that indicated by `arg1`, + * in the context of this `frame`. + */ +struct cons_pointer subtract_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer result = NIL; + + switch ( pointer2cell( arg1 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[0]; + result = arg1; break; case INTEGERTV: - switch ( cell1.tag.value ) { + switch ( pointer2cell( arg2 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[1]; + result = arg2; break; - case INTEGERTV: - result = make_integer( cell0.payload.integer.value - - cell1.payload.integer.value ); + case INTEGERTV:{ + struct cons_pointer i = + negative( frame_pointer, arg2 ); + inc_ref( i ); + result = add_integers( arg1, i ); + dec_ref( i ); + } break; case RATIOTV:{ struct cons_pointer tmp = - make_ratio( frame_pointer, frame->arg[0], - make_integer( 1 ) ); + make_ratio( frame_pointer, arg1, + make_integer( 1, NIL ) ); inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, tmp, - frame->arg[1] ); + subtract_ratio_ratio( frame_pointer, tmp, arg2 ); dec_ref( tmp ); } break; case REALTV: result = - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + make_real( to_long_double( arg1 ) - + to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -479,30 +600,27 @@ struct cons_pointer lisp_subtract( struct } break; case RATIOTV: - switch ( cell1.tag.value ) { + switch ( pointer2cell( arg2 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[1]; + result = arg2; break; case INTEGERTV:{ struct cons_pointer tmp = - make_ratio( frame_pointer, frame->arg[1], - make_integer( 1 ) ); + make_ratio( frame_pointer, arg2, + make_integer( 1, NIL ) ); inc_ref( tmp ); result = - subtract_ratio_ratio( frame_pointer, frame->arg[0], - tmp ); + subtract_ratio_ratio( frame_pointer, arg1, tmp ); dec_ref( tmp ); } break; case RATIOTV: - result = - subtract_ratio_ratio( frame_pointer, frame->arg[0], - frame->arg[1] ); + result = subtract_ratio_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + make_real( to_long_double( arg1 ) - + to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -512,9 +630,8 @@ struct cons_pointer lisp_subtract( struct } 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] ) ); + result = exceptionp( arg2 ) ? arg2 : + make_real( to_long_double( arg1 ) - to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -529,10 +646,27 @@ struct cons_pointer lisp_subtract( struct } /** - * Divide one number by another. + * Subtract one number from another. If more than two arguments are passed + * in the frame, the additional arguments are ignored. + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer, ratio or real. + * @exception if either argument is not a number, returns an exception. + */ +struct cons_pointer lisp_subtract( struct + stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return subtract_2( frame, frame_pointer, frame->arg[0], frame->arg[1] ); +} + +/** + * Divide one number by another. If more than two arguments are passed + * in the frame, the additional arguments are ignored. * @param env the evaluation environment - ignored; * @param frame the stack frame. * @return a pointer to an integer or real. + * @exception if either argument is not a number, returns an exception. */ struct cons_pointer lisp_divide( struct stack_frame @@ -564,7 +698,7 @@ struct cons_pointer lisp_divide( struct } break; case RATIOTV:{ - struct cons_pointer one = make_integer( 1 ); + struct cons_pointer one = make_integer( 1, NIL ); struct cons_pointer ratio = make_ratio( frame_pointer, frame->arg[0], one ); inc_ref( ratio ); @@ -592,7 +726,7 @@ struct cons_pointer lisp_divide( struct result = frame->arg[1]; break; case INTEGERTV:{ - struct cons_pointer one = make_integer( 1 ); + struct cons_pointer one = make_integer( 1, NIL ); inc_ref( one ); struct cons_pointer ratio = make_ratio( frame_pointer, frame->arg[1], one ); diff --git a/src/arith/peano.h b/src/arith/peano.h index f1c21b4..7ad7662 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -1,4 +1,4 @@ -/** +/* * peano.h * * Basic peano arithmetic @@ -12,53 +12,54 @@ #ifndef PEANO_H #define PEANO_H -#ifdef __cplusplus -extern "C" { -#endif - /** - * 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. + * The maximum value we will allow in an integer cell. */ - struct cons_pointer - lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +#define MAX_INTEGER ((__int128_t)0x0fffffffffffffffL) -/** - * 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 ); +bool zerop( struct cons_pointer arg ); -/** - * 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 negative( struct cons_pointer frame, + struct cons_pointer arg ); -/** - * 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 ); +bool is_negative( struct cons_pointer arg ); -#ifdef __cplusplus -} -#endif -#endif /* PEANO_H */ +struct cons_pointer absolute( struct cons_pointer frame_pointer, + struct cons_pointer arg ); + +long double to_long_double( struct cons_pointer arg ); + +struct cons_pointer lisp_absolute( struct stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ); + +struct cons_pointer +lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_is_negative( struct stack_frame + *frame, + struct cons_pointer frame_pointer, struct + cons_pointer env ); + +struct cons_pointer +lisp_multiply( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); + +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ); + +struct cons_pointer subtract_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ); + +struct cons_pointer +lisp_subtract( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); + +struct cons_pointer +lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); + +#endif /* PEANO_H */ diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 31dd0a2..65b09da 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -17,17 +17,11 @@ #include "equal.h" #include "integer.h" #include "lispops.h" +#include "peano.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`, */ @@ -52,8 +46,8 @@ int64_t least_common_multiple( int64_t m, int64_t 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. + * be in a simplified representation. + * @exception If `arg` isn't a ratio, will return an exception. */ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg ) { @@ -61,18 +55,18 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, if ( ratiop( arg ) ) { int64_t ddrv = - pointer2cell( pointer2cell( arg ).payload.ratio.dividend ).payload. - integer.value, drrv = - pointer2cell( pointer2cell( arg ).payload.ratio.divisor ).payload. - integer.value, gcd = greatest_common_divisor( ddrv, drrv ); + pointer2cell( pointer2cell( arg ).payload.ratio.dividend ). + payload.integer.value, drrv = + pointer2cell( pointer2cell( arg ).payload.ratio.divisor ). + payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv ); if ( gcd > 1 ) { if ( drrv / gcd == 1 ) { - result = make_integer( ddrv / gcd ); + result = make_integer( ddrv / gcd, NIL ); } else { result = - make_ratio( frame_pointer, make_integer( ddrv / gcd ), - make_integer( drrv / gcd ) ); + make_ratio( frame_pointer, make_integer( ddrv / gcd, NIL ), + make_integer( drrv / gcd, NIL ) ); } } } else { @@ -89,8 +83,9 @@ struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, /** * 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. + * the ratios indicated by `arg1` and `arg2`. + * @exception will return an exception if either `arg1` or `arg2` is not a + * rational number. */ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, @@ -122,13 +117,13 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, if ( dr1v == dr2v ) { r = make_ratio( frame_pointer, - make_integer( dd1v + dd2v ), + make_integer( dd1v + dd2v, NIL ), 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 ), + struct cons_pointer dd1vm = make_integer( dd1v * m1, NIL ), + dr1vm = make_integer( dr1v * m1, NIL ), + dd2vm = make_integer( dd2v * m2, NIL ), + dr2vm = make_integer( dr2v * m2, NIL ), r1 = make_ratio( frame_pointer, dd1vm, dr1vm ), r2 = make_ratio( frame_pointer, dd2vm, dr2vm ); @@ -165,7 +160,8 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, /** * 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. + * `ratarg`. + * @exception if either `intarg` or `ratarg` is not of the expected type. */ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer intarg, @@ -173,7 +169,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { - struct cons_pointer one = make_integer( 1 ), + struct cons_pointer one = make_integer( 1, NIL ), ratio = make_ratio( frame_pointer, intarg, one ); result = add_ratio_ratio( frame_pointer, ratio, ratarg ); @@ -195,17 +191,18 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, /** * 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. + * indicated by `arg1` divided by the ratio indicated by `arg2`. + * @exception will return an exception if either `arg1` or `arg2` is not a + * rational number. */ 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 = + pointer2cell( arg2 ).payload. + ratio.divisor, + pointer2cell( arg2 ).payload. + ratio.dividend ), result = multiply_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); @@ -215,8 +212,9 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, /** * 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. + * the ratios indicated by `arg1` and `arg2`. + * @exception will return an exception if either `arg1` or `arg2` is not a + * rational number. */ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct @@ -243,8 +241,8 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str ddrv = dd1v * dd2v, drrv = dr1v * dr2v; struct cons_pointer unsimplified = - make_ratio( frame_pointer, make_integer( ddrv ), - make_integer( drrv ) ); + make_ratio( frame_pointer, make_integer( ddrv, NIL ), + make_integer( drrv, NIL ) ); result = simplify_ratio( frame_pointer, unsimplified ); if ( !eq( unsimplified, result ) ) { @@ -263,7 +261,8 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str /** * 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. + * `ratarg`. + * @exception if either `intarg` or `ratarg` is not of the expected type. */ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer intarg, @@ -271,7 +270,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { - struct cons_pointer one = make_integer( 1 ), + struct cons_pointer one = make_integer( 1, NIL ), ratio = make_ratio( frame_pointer, intarg, one ); result = multiply_ratio_ratio( frame_pointer, ratio, ratarg ); @@ -290,13 +289,14 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, /** * 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. + * the ratios indicated by `arg1` and `arg2`. + * @exception will return an exception if either `arg1` or `arg2` is not a + * rational number. */ 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 ), + struct cons_pointer i = negative( frame_pointer, arg2 ), result = add_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); @@ -306,8 +306,10 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, /** - * Construct a ratio frame from these two pointers, expected to be integers - * or (later) bignums, in the context of this stack_frame. + * Construct a ratio frame from this `dividend` and `divisor`, expected to + * be integers, in the context of the stack_frame indicated by this + * `frame_pointer`. + * @exception if either `dividend` or `divisor` is not an integer. */ struct cons_pointer make_ratio( struct cons_pointer frame_pointer, struct cons_pointer dividend, diff --git a/src/debug.c b/src/debug.c index eba31e8..c8b9771 100644 --- a/src/debug.c +++ b/src/debug.c @@ -21,6 +21,7 @@ #include "consspaceobject.h" #include "debug.h" #include "dump.h" +#include "io.h" #include "print.h" /** @@ -42,6 +43,30 @@ void debug_print( wchar_t *message, int level ) { #endif } +/** + * stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc + */ +void debug_print_128bit( __int128_t n, int level ) { +#ifdef DEBUG + if ( level & verbosity ) { + if ( n == 0 ) { + fwprintf( stderr, L"0" ); + } else { + char str[40] = { 0 }; // log10(1 << 128) + '\0' + char *s = str + sizeof( str ) - 1; // start at the end + while ( n != 0 ) { + if ( s == str ) + return; // never happens + + *--s = "0123456789"[n % 10]; // save last digit + n /= 10; // drop it + } + fwprintf( stderr, L"%s", s ); + } + } +#endif +} + /** * print a line feed to stderr, if `verbosity` matches `level`. * `verbosity is a set of flags, see debug_print.h; so you can @@ -80,8 +105,10 @@ void debug_printf( int level, wchar_t *format, ... ) { void debug_print_object( struct cons_pointer pointer, int level ) { #ifdef DEBUG if ( level & verbosity ) { + URL_FILE *ustderr = file_to_url_file( stderr ); fwide( stderr, 1 ); - print( stderr, pointer ); + print( ustderr, pointer ); + free( ustderr ); } #endif } @@ -92,8 +119,10 @@ void debug_print_object( struct cons_pointer pointer, int level ) { void debug_dump_object( struct cons_pointer pointer, int level ) { #ifdef DEBUG if ( level & verbosity ) { + URL_FILE *ustderr = file_to_url_file( stderr ); fwide( stderr, 1 ); - dump_object( stderr, pointer ); + dump_object( ustderr, pointer ); + free( ustderr ); } #endif } diff --git a/src/debug.h b/src/debug.h index 72fa020..babbaea 100644 --- a/src/debug.h +++ b/src/debug.h @@ -14,18 +14,19 @@ #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_ARITH 2 +#define DEBUG_BIND 4 +#define DEBUG_BOOTSTRAP 8 +#define DEBUG_EVAL 16 +#define DEBUG_IO 32 +#define DEBUG_LAMBDA 64 #define DEBUG_REPL 128 -#define DEBUG_BIND 256 +#define DEBUG_STACK 256 extern int verbosity; void debug_print( wchar_t *message, int level ); +void debug_print_128bit( __int128_t n, 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 ); diff --git a/src/init.c b/src/init.c index 9cbe701..c180b10 100644 --- a/src/init.c +++ b/src/init.c @@ -9,17 +9,22 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include #include #include #include #include +/* libcurl, used for io */ +#include + #include "version.h" #include "conspage.h" #include "consspaceobject.h" #include "debug.h" #include "intern.h" +#include "io.h" #include "lispops.h" #include "peano.h" #include "print.h" @@ -27,51 +32,63 @@ // extern char *optarg; /* defined in unistd.h */ +/** + * Bind this compiled `executable` function, as a Lisp function, to + * this name in the `oblist`. + * \todo where a function is not compiled from source, we could cache + * the name on the source pointer. Would make stack frames potentially + * more readable and aid debugging generally. + */ void bind_function( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { - struct cons_pointer n = c_string_to_lisp_symbol( name ); - inc_ref(n); + struct cons_pointer n = c_string_to_lisp_symbol( name ); + inc_ref( n ); - /* TODO: where a function is not compiled from source, we could cache - * the name on the source pointer. Would make stack frames potentially - * more readable and aid debugging generally. */ deep_bind( n, make_function( NIL, executable ) ); - dec_ref(n); + dec_ref( n ); } +/** + * Bind this compiled `executable` function, as a Lisp special form, to + * this `name` in the `oblist`. + */ void bind_special( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { - struct cons_pointer n = c_string_to_lisp_symbol( name ); - inc_ref(n); + struct cons_pointer n = c_string_to_lisp_symbol( name ); + inc_ref( n ); - deep_bind( n, make_special( NIL, executable ) ); + deep_bind( n, make_special( NIL, executable ) ); - dec_ref(n); + dec_ref( n ); } -void bind_value( wchar_t *name, struct cons_pointer value) { - struct cons_pointer n = c_string_to_lisp_symbol( name ); - inc_ref(n); +/** + * Bind this `value` to this `name` in the `oblist`. + */ +void bind_value( wchar_t *name, struct cons_pointer value ) { + struct cons_pointer n = c_string_to_lisp_symbol( name ); + inc_ref( n ); - deep_bind( n, value ); + deep_bind( n, value ); - dec_ref(n); + dec_ref( n ); } +/** + * main entry point; parse command line arguments, initialise the environment, + * and enter the read-eval-print loop. + */ int main( int argc, char *argv[] ) { - /* - * attempt to set wide character acceptance on all streams - */ - fwide( stdin, 1 ); - fwide( stdout, 1 ); - fwide( stderr, 1 ); int option; bool dump_at_end = false; bool show_prompt = false; + setlocale( LC_ALL, "" ); + curl_global_init( CURL_GLOBAL_DEFAULT ); + while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { switch ( option ) { case 'c': @@ -107,30 +124,59 @@ int main( int argc, char *argv[] ) { /* * privileged variables (keywords) */ - bind_value( L"nil" , NIL ); - bind_value( L"t" , TRUE ); + bind_value( L"nil", NIL ); + bind_value( L"t", TRUE ); + + /* + * standard input, output, error and sink streams + * attempt to set wide character acceptance on all streams + */ + URL_FILE *sink = url_fopen( "/dev/null", "w" ); + fwide( stdin, 1 ); + fwide( stdout, 1 ); + fwide( stderr, 1 ); + fwide( sink->handle.file, 1 ); + bind_value( L"*in*", make_read_stream( file_to_url_file( stdin ) ) ); + bind_value( L"*out*", make_write_stream( file_to_url_file( stdout ) ) ); + bind_value( L"*log*", make_write_stream( file_to_url_file( stderr ) ) ); + bind_value( L"*sink*", make_write_stream( sink ) ); + + /* + * the default prompt + */ + bind_value( L"*prompt*", + show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL ); /* * primitive function operations */ + bind_function( L"absolute", &lisp_absolute ); 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"close", &lisp_close ); 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"inspect", &lisp_inspect ); bind_function( L"multiply", &lisp_multiply ); - bind_function( L"read", &lisp_read ); + bind_function( L"negative?", &lisp_is_negative ); bind_function( L"oblist", &lisp_oblist ); + bind_function( L"open", &lisp_open ); bind_function( L"print", &lisp_print ); bind_function( L"progn", &lisp_progn ); + bind_function( L"read", &lisp_read ); + bind_function( L"read-char", &lisp_read_char ); + bind_function( L"repl", &lisp_repl ); bind_function( L"reverse", &lisp_reverse ); bind_function( L"set", &lisp_set ); + bind_function( L"slurp", &lisp_slurp ); + bind_function( L"source", &lisp_source ); bind_function( L"subtract", &lisp_subtract ); bind_function( L"throw", &lisp_exception ); bind_function( L"type", &lisp_type ); @@ -146,25 +192,24 @@ int main( int argc, char *argv[] ) { */ bind_special( L"cond", &lisp_cond ); bind_special( L"lambda", &lisp_lambda ); - // bind_special( L"λ", &lisp_lambda ); + bind_special( L"\u03bb", &lisp_lambda ); // λ bind_special( L"nlambda", &lisp_nlambda ); - // bind_special( L"nλ", &lisp_nlambda ); + bind_special( L"n\u03bb", &lisp_nlambda ); bind_special( L"progn", &lisp_progn ); bind_special( L"quote", &lisp_quote ); bind_special( L"set!", &lisp_set_shriek ); - debug_print(L"Initialised oblist\n", DEBUG_BOOTSTRAP); - debug_dump_object(oblist, DEBUG_BOOTSTRAP); + debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP ); + debug_dump_object( oblist, DEBUG_BOOTSTRAP ); - repl( stdin, stdout, stderr, show_prompt ); - - debug_print(L"Freeing oblist\n", DEBUG_BOOTSTRAP); - dec_ref(oblist); - debug_dump_object(oblist, DEBUG_BOOTSTRAP); + repl( show_prompt ); + debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP ); + dec_ref( oblist ); + debug_dump_object( oblist, DEBUG_BOOTSTRAP ); if ( dump_at_end ) { - dump_pages( stdout ); + dump_pages( file_to_url_file( stdout ) ); } return ( 0 ); diff --git a/src/io/fopen.c b/src/io/fopen.c new file mode 100644 index 0000000..f0ea012 --- /dev/null +++ b/src/io/fopen.c @@ -0,0 +1,546 @@ +/* + * fopen.c + * + * adapted from https://curl.haxx.se/libcurl/c/fopen.html. + * + * Modifications to read/write wide character streams by + * Simon Brooke. + * + * NOTE THAT: for my purposes, I'm only interested in wide characters, + * and I always read them one character at a time. + * + * Copyright (c) 2003, 2017 Simtec Electronics + * Some portions (c) 2019 Simon Brooke + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. The name of the author may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * This example requires libcurl 7.9.7 or later. + */ + +#include +#include +#ifndef WIN32 +#include +#endif +#include +#include + +#include + +enum fcurl_type_e { + CFTYPE_NONE = 0, + CFTYPE_FILE = 1, + CFTYPE_CURL = 2 +}; + +struct fcurl_data +{ + enum fcurl_type_e type; /* type of handle */ + union { + CURL *curl; + FILE *file; + } handle; /* handle */ + + char *buffer; /* buffer to store cached data*/ + size_t buffer_len; /* currently allocated buffers length */ + size_t buffer_pos; /* end of data in buffer*/ + int still_running; /* Is background url fetch still in progress */ +}; + +typedef struct fcurl_data URL_FILE; + +/* exported functions */ +URL_FILE *url_fopen(const char *url, const char *operation); +int url_fclose(URL_FILE *file); +int url_feof(URL_FILE *file); +size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file); +char *url_fgets(char *ptr, size_t size, URL_FILE *file); +void url_rewind(URL_FILE *file); + +/* we use a global one for convenience */ +static CURLM *multi_handle; + +/* curl calls this routine to get more data */ +static size_t write_callback(char *buffer, + size_t size, + size_t nitems, + void *userp) +{ + char *newbuff; + size_t rembuff; + + URL_FILE *url = (URL_FILE *)userp; + size *= nitems; + + rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ + + if(size > rembuff) { + /* not enough space in buffer */ + newbuff = realloc(url->buffer, url->buffer_len + (size - rembuff)); + if(newbuff == NULL) { + fprintf(stderr, "callback buffer grow failed\n"); + size = rembuff; + } + else { + /* realloc succeeded increase buffer size*/ + url->buffer_len += size - rembuff; + url->buffer = newbuff; + } + } + + memcpy(&url->buffer[url->buffer_pos], buffer, size); + url->buffer_pos += size; + + return size; +} + +/* use to attempt to fill the read buffer up to requested number of bytes */ +static int fill_buffer(URL_FILE *file, size_t want) +{ + fd_set fdread; + fd_set fdwrite; + fd_set fdexcep; + struct timeval timeout; + int rc; + CURLMcode mc; /* curl_multi_fdset() return code */ + + /* only attempt to fill buffer if transactions still running and buffer + * doesn't exceed required size already + */ + if((!file->still_running) || (file->buffer_pos > want)) + return 0; + + /* attempt to fill buffer */ + do { + int maxfd = -1; + long curl_timeo = -1; + + FD_ZERO(&fdread); + FD_ZERO(&fdwrite); + FD_ZERO(&fdexcep); + + /* set a suitable timeout to fail on */ + timeout.tv_sec = 60; /* 1 minute */ + timeout.tv_usec = 0; + + curl_multi_timeout(multi_handle, &curl_timeo); + if(curl_timeo >= 0) { + timeout.tv_sec = curl_timeo / 1000; + if(timeout.tv_sec > 1) + timeout.tv_sec = 1; + else + timeout.tv_usec = (curl_timeo % 1000) * 1000; + } + + /* get file descriptors from the transfers */ + mc = curl_multi_fdset(multi_handle, &fdread, &fdwrite, &fdexcep, &maxfd); + + if(mc != CURLM_OK) { + fprintf(stderr, "curl_multi_fdset() failed, code %d.\n", mc); + break; + } + + /* On success the value of maxfd is guaranteed to be >= -1. We call + select(maxfd + 1, ...); specially in case of (maxfd == -1) there are + no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- + to sleep 100ms, which is the minimum suggested value in the + curl_multi_fdset() doc. */ + + if(maxfd == -1) { +#ifdef _WIN32 + Sleep(100); + rc = 0; +#else + /* Portable sleep for platforms other than Windows. */ + struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ + rc = select(0, NULL, NULL, NULL, &wait); +#endif + } + else { + /* Note that on some platforms 'timeout' may be modified by select(). + If you need access to the original value save a copy beforehand. */ + rc = select(maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout); + } + + switch(rc) { + case -1: + /* select error */ + break; + + case 0: + default: + /* timeout or readable/writable sockets */ + curl_multi_perform(multi_handle, &file->still_running); + break; + } + } while(file->still_running && (file->buffer_pos < want)); + return 1; +} + +/* use to remove want bytes from the front of a files buffer */ +static int use_buffer(URL_FILE *file, size_t want) +{ + /* sort out buffer */ + if((file->buffer_pos - want) <= 0) { + /* ditch buffer - write will recreate */ + free(file->buffer); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + } + else { + /* move rest down make it available for later */ + memmove(file->buffer, + &file->buffer[want], + (file->buffer_pos - want)); + + file->buffer_pos -= want; + } + return 0; +} + +URL_FILE *url_fopen(const char *url, const char *operation) +{ + /* this code could check for URLs or types in the 'url' and + basically use the real fopen() for standard files */ + + URL_FILE *file; + (void)operation; + + file = calloc(1, sizeof(URL_FILE)); + if(!file) + return NULL; + + file->handle.file = fopen(url, operation); + if(file->handle.file) + file->type = CFTYPE_FILE; /* marked as URL */ + + else { + file->type = CFTYPE_CURL; /* marked as URL */ + file->handle.curl = curl_easy_init(); + + curl_easy_setopt(file->handle.curl, CURLOPT_URL, url); + curl_easy_setopt(file->handle.curl, CURLOPT_WRITEDATA, file); + curl_easy_setopt(file->handle.curl, CURLOPT_VERBOSE, 0L); + curl_easy_setopt(file->handle.curl, CURLOPT_WRITEFUNCTION, write_callback); + + if(!multi_handle) + multi_handle = curl_multi_init(); + + curl_multi_add_handle(multi_handle, file->handle.curl); + + /* lets start the fetch */ + curl_multi_perform(multi_handle, &file->still_running); + + if((file->buffer_pos == 0) && (!file->still_running)) { + /* if still_running is 0 now, we should return NULL */ + + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle(multi_handle, file->handle.curl); + + /* cleanup */ + curl_easy_cleanup(file->handle.curl); + + free(file); + + file = NULL; + } + } + return file; +} + +int url_fclose(URL_FILE *file) +{ + int ret = 0;/* default is good return */ + + switch(file->type) { + case CFTYPE_FILE: + ret = fclose(file->handle.file); /* passthrough */ + break; + + case CFTYPE_CURL: + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle(multi_handle, file->handle.curl); + + /* cleanup */ + curl_easy_cleanup(file->handle.curl); + break; + + default: /* unknown or supported type - oh dear */ + ret = EOF; + errno = EBADF; + break; + } + + free(file->buffer);/* free any allocated buffer space */ + free(file); + + return ret; +} + +int url_feof(URL_FILE *file) +{ + int ret = 0; + + switch(file->type) { + case CFTYPE_FILE: + ret = feof(file->handle.file); + break; + + case CFTYPE_CURL: + if((file->buffer_pos == 0) && (!file->still_running)) + ret = 1; + break; + + default: /* unknown or supported type - oh dear */ + ret = -1; + errno = EBADF; + break; + } + return ret; +} + +size_t url_fread(void *ptr, size_t size, size_t nmemb, URL_FILE *file) +{ + size_t want; + + switch(file->type) { + case CFTYPE_FILE: + want = fread(ptr, size, nmemb, file->handle.file); + break; + + case CFTYPE_CURL: + want = nmemb * size; + + fill_buffer(file, want); + + /* check if there's data in the buffer - if not fill_buffer() + * either errored or EOF */ + if(!file->buffer_pos) + return 0; + + /* ensure only available data is considered */ + if(file->buffer_pos < want) + want = file->buffer_pos; + + /* xfer data to caller */ + memcpy(ptr, file->buffer, want); + + use_buffer(file, want); + + want = want / size; /* number of items */ + break; + + default: /* unknown or supported type - oh dear */ + want = 0; + errno = EBADF; + break; + + } + return want; +} + +char *url_fgets(char *ptr, size_t size, URL_FILE *file) +{ + size_t want = size - 1;/* always need to leave room for zero termination */ + size_t loop; + + switch(file->type) { + case CFTYPE_FILE: + ptr = fgets(ptr, (int)size, file->handle.file); + break; + + case CFTYPE_CURL: + fill_buffer(file, want); + + /* check if there's data in the buffer - if not fill either errored or + * EOF */ + if(!file->buffer_pos) + return NULL; + + /* ensure only available data is considered */ + if(file->buffer_pos < want) + want = file->buffer_pos; + + /*buffer contains data */ + /* look for newline or eof */ + for(loop = 0; loop < want; loop++) { + if(file->buffer[loop] == '\n') { + want = loop + 1;/* include newline */ + break; + } + } + + /* xfer data to caller */ + memcpy(ptr, file->buffer, want); + ptr[want] = 0;/* always null terminate */ + + use_buffer(file, want); + + break; + + default: /* unknown or supported type - oh dear */ + ptr = NULL; + errno = EBADF; + break; + } + + return ptr;/*success */ +} + +void url_rewind(URL_FILE *file) +{ + switch(file->type) { + case CFTYPE_FILE: + rewind(file->handle.file); /* passthrough */ + break; + + case CFTYPE_CURL: + /* halt transaction */ + curl_multi_remove_handle(multi_handle, file->handle.curl); + + /* restart */ + curl_multi_add_handle(multi_handle, file->handle.curl); + + /* ditch buffer - write will recreate - resets stream pos*/ + free(file->buffer); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + + break; + + default: /* unknown or supported type - oh dear */ + break; + } +} + +#ifdef FOPEN_STANDALONE +#define FGETSFILE "fgets.test" +#define FREADFILE "fread.test" +#define REWINDFILE "rewind.test" + +/* Small main program to retrieve from a url using fgets and fread saving the + * output to two test files (note the fgets method will corrupt binary files if + * they contain 0 chars */ +int main(int argc, char *argv[]) +{ + URL_FILE *handle; + FILE *outf; + + size_t nread; + char buffer[256]; + const char *url; + + CURL *curl; + CURLcode res; + + curl_global_init(CURL_GLOBAL_DEFAULT); + + curl = curl_easy_init(); + + + if(argc < 2) + url = "http://192.168.7.3/testfile";/* default to testurl */ + else + url = argv[1];/* use passed url */ + + /* copy from url line by line with fgets */ + outf = fopen(FGETSFILE, "wb+"); + if(!outf) { + perror("couldn't open fgets output file\n"); + return 1; + } + + handle = url_fopen(url, "r"); + if(!handle) { + printf("couldn't url_fopen() %s\n", url); + fclose(outf); + return 2; + } + + while(!url_feof(handle)) { + url_fgets(buffer, sizeof(buffer), handle); + fwrite(buffer, 1, strlen(buffer), outf); + } + + url_fclose(handle); + + fclose(outf); + + + /* Copy from url with fread */ + outf = fopen(FREADFILE, "wb+"); + if(!outf) { + perror("couldn't open fread output file\n"); + return 1; + } + + handle = url_fopen("testfile", "r"); + if(!handle) { + printf("couldn't url_fopen() testfile\n"); + fclose(outf); + return 2; + } + + do { + nread = url_fread(buffer, 1, sizeof(buffer), handle); + fwrite(buffer, 1, nread, outf); + } while(nread); + + url_fclose(handle); + + fclose(outf); + + + /* Test rewind */ + outf = fopen(REWINDFILE, "wb+"); + if(!outf) { + perror("couldn't open fread output file\n"); + return 1; + } + + handle = url_fopen("testfile", "r"); + if(!handle) { + printf("couldn't url_fopen() testfile\n"); + fclose(outf); + return 2; + } + + nread = url_fread(buffer, 1, sizeof(buffer), handle); + fwrite(buffer, 1, nread, outf); + url_rewind(handle); + + buffer[0]='\n'; + fwrite(buffer, 1, 1, outf); + + nread = url_fread(buffer, 1, sizeof(buffer), handle); + fwrite(buffer, 1, nread, outf); + + url_fclose(handle); + + fclose(outf); + + return 0;/* all done */ +} +#endif diff --git a/src/io/fopen.h b/src/io/fopen.h new file mode 100644 index 0000000..5f87bd2 --- /dev/null +++ b/src/io/fopen.h @@ -0,0 +1,83 @@ +/* + * fopen.h + * + * adapted from https://curl.haxx.se/libcurl/c/fopen.html. + * + * + * Modifications to read/write wide character streams by + * Simon Brooke. + * + * NOTE THAT: for my purposes, I'm only interested in wide characters, + * and I always read them one character at a time. + * + * Copyright (c) 2003, 2017 Simtec Electronics + * Some portions (c) 2019 Simon Brooke + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. The name of the author may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * This example requires libcurl 7.9.7 or later. + */ + +#ifndef __fopen_h +#define __fopen_h +#include +/* + * wide characters + */ +#include +#include + +#define url_fwprintf(f, ...) ((f->type = CFTYPE_FILE) ? fwprintf( f->handle.file, __VA_ARGS__) : -1) +#define url_fputws(ws, f) ((f->type = CFTYPE_FILE) ? fputws(ws, f->handle.file) : 0) +#define url_fputwc(wc, f) ((f->type = CFTYPE_FILE) ? fputwc(wc, f->handle.file) : 0) + +enum fcurl_type_e { + CFTYPE_NONE = 0, + CFTYPE_FILE = 1, + CFTYPE_CURL = 2 +}; + +struct fcurl_data { + enum fcurl_type_e type; /* type of handle */ + union { + CURL *curl; + FILE *file; + } handle; /* handle */ + + char *buffer; /* buffer to store cached data */ + size_t buffer_len; /* currently allocated buffer's length */ + size_t buffer_pos; /* cursor into in buffer */ + int still_running; /* Is background url fetch still in progress */ +}; + +typedef struct fcurl_data URL_FILE; + +/* exported functions */ +URL_FILE *url_fopen( const char *url, const char *operation ); +int url_fclose( URL_FILE * file ); +int url_feof( URL_FILE * file ); +size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ); +char *url_fgets( char *ptr, size_t size, URL_FILE * file ); +void url_rewind( URL_FILE * file ); + +#endif diff --git a/src/io/io.c b/src/io/io.c new file mode 100644 index 0000000..d7c2024 --- /dev/null +++ b/src/io/io.c @@ -0,0 +1,319 @@ +/* + * io.c + * + * Communication between PSSE and the outside world, via libcurl. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "conspage.h" +#include "consspaceobject.h" +#include "debug.h" +#include "fopen.h" +#include "lispops.h" + +/** + * Allow a one-character unget facility. This may not be enough - we may need + * to allocate a buffer. + */ +wint_t ungotten = 0; + +/** + * Convert this lisp string-like-thing (also works for symbols, and, later + * keywords) into a UTF-8 string. NOTE that the returned value has been + * malloced and must be freed. TODO: candidate to moving into a utilities + * file. + * + * @param s the lisp string or symbol; + * @return the c string. + */ +char *lisp_string_to_c_string( struct cons_pointer s ) { + char *result = NULL; + + if ( stringp( s ) || symbolp( s ) ) { + int len = 0; + + for ( struct cons_pointer c = s; !nilp( c ); + c = pointer2cell( c ).payload.string.cdr ) { + len++; + } + + wchar_t *buffer = calloc( len + 1, sizeof( wchar_t ) ); + /* worst case, one wide char = four utf bytes */ + result = calloc( ( len * 4 ) + 1, sizeof( char ) ); + + int i = 0; + for ( struct cons_pointer c = s; !nilp( c ); + c = pointer2cell( c ).payload.string.cdr ) { + buffer[i++] = pointer2cell( c ).payload.string.character; + } + + wcstombs( result, buffer, len ); + free( buffer ); + } + + debug_print( L"lisp_string_to_c_string( ", DEBUG_IO ); + debug_print_object( s, DEBUG_IO ); + debug_printf( DEBUG_IO, L") => '%s'\n", result ); + + return result; +} + + +/** + * given this file handle f, return a new url_file handle wrapping it. + * + * @param f the file to be wrapped; + * @return the new handle, or null if no such handle could be allocated. + */ +URL_FILE *file_to_url_file( FILE * f ) { + URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) ); + + if ( result != NULL ) { + result->type = CFTYPE_FILE, result->handle.file = f; + } + + return result; +} + + +/** + * get one wide character from the buffer. + * + * @param file the stream to read from; + * @return the next wide character on the stream, or zero if no more. + */ +wint_t url_fgetwc( URL_FILE * input ) { + wint_t result = -1; + + if ( ungotten != 0 ) { + /* TODO: not thread safe */ + result = ungotten; + ungotten = 0; + } else { + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = fgetwc( input->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL:{ + char *cbuff = + calloc( sizeof( wchar_t ) + 2, sizeof( char ) ); + wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + + size_t count = 0; + + debug_print( L"url_fgetwc: about to call url_fgets\n", DEBUG_IO ); + url_fgets( cbuff, 2, input ); + debug_print( L"url_fgetwc: back from url_fgets\n", DEBUG_IO ); + int c = ( int ) cbuff[0]; + debug_printf( DEBUG_IO, + L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n", + cbuff, c, c & 0xf7 ); + /* The value of each individual byte indicates its UTF-8 function, as follows: + * + * 00 to 7F hex (0 to 127): first and only byte of a sequence. + * 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence. + * C2 to DF hex (194 to 223): first byte of a two-byte sequence. + * E0 to EF hex (224 to 239): first byte of a three-byte sequence. + * F0 to FF hex (240 to 255): first byte of a four-byte sequence. + */ + if ( c <= 0x07 ) { + count = 1; + } else if ( c >= '0xc2' && c <= '0xdf' ) { + count = 2; + } else if ( c >= '0xe0' && c <= '0xef' ) { + count = 3; + } else if ( c >= '0xf0' && c <= '0xff' ) { + count = 4; + } + + if ( count > 1 ) { + url_fgets( (char *)&cbuff[1], count, input ); + } + mbstowcs( wbuff, cbuff, 1 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); + result = wbuff[0]; + + free( wbuff ); + free( cbuff ); + } + break; + case CFTYPE_NONE: + break; + } + } + + debug_printf( DEBUG_IO, L"url_fgetwc returning %d (%C)\n", result, + result ); + return result; +} + +wint_t url_ungetwc( wint_t wc, URL_FILE * input ) { + wint_t result = -1; + + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = ungetwc( wc, input->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL:{ + ungotten = wc; +// wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); +// char *cbuff = calloc( 5, sizeof( char ) ); +// +// wbuff[0] = wc; +// result = wcstombs( cbuff, wbuff, 1 ); +// +// input->buffer_pos -= strlen( cbuff ); +// +// free( cbuff ); +// free( wbuff ); +// +// result = result > 0 ? wc : result; + break; + case CFTYPE_NONE: + break; + } + } + + return result; +} + + +/** + * Function, sort-of: close the file indicated by my first arg, and return + * nil. If the first arg is not a stream, does nothing. All other args are + * ignored. + * + * * (close stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return T if the stream was successfully closed, else NIL. + */ +struct cons_pointer +lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( readp( frame->arg[0] ) || writep( frame->arg[0] ) ) { + if ( url_fclose( pointer2cell( frame->arg[0] ).payload.stream.stream ) + == 0 ) { + result = TRUE; + } + } + + return result; +} + +/** + * Function: return a stream open on the URL indicated by the first argument; + * if a second argument is present and is non-nil, open it for reading. At + * present, further arguments are ignored and there is no mechanism to open + * to append, or error if the URL is faulty or indicates an unavailable + * resource. + * + * * (read-char stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else NIL. + */ +struct cons_pointer +lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( stringp( frame->arg[0] ) ) { + char *url = lisp_string_to_c_string( frame->arg[0] ); + + if ( nilp( frame->arg[1] ) ) { + result = make_read_stream( url_fopen( url, "r" ) ); + } else { + // TODO: anything more complex is a problem for another day. + result = make_write_stream( url_fopen( url, "w" ) ); + } + + free( url ); + + if ( pointer2cell( result ).payload.stream.stream == NULL ) { + result = NIL; + } + } + + return result; +} + +/** + * Function: return the next character from the stream indicated by arg 0; + * further arguments are ignored. + * + * * (read-char stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else NIL. + */ +struct cons_pointer +lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( readp( frame->arg[0] ) ) { + result = + make_string( url_fgetwc + ( pointer2cell( frame->arg[0] ).payload.stream. + stream ), NIL ); + } + + return result; +} + +/** + * Function: return a string representing all characters from the stream + * indicated by arg 0; further arguments are ignored. + * + * * (slurp stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else NIL. + */ +struct cons_pointer +lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( readp( frame->arg[0] ) ) { + URL_FILE *stream = pointer2cell( frame->arg[0] ).payload.stream.stream; + struct cons_pointer cursor = make_string( url_fgetwc( stream ), NIL ); + result = cursor; + + for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ) && c != 0; + c = url_fgetwc( stream ) ) { + debug_print( L"slurp: cursor is: ", DEBUG_IO ); + debug_dump_object( cursor, DEBUG_IO ); + debug_print( L"; result is: ", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + debug_println( DEBUG_IO ); + + struct cons_space_object *cell = &pointer2cell( cursor ); + cursor = make_string( ( wchar_t ) c, NIL ); + cell->payload.string.cdr = cursor; + } + } + + return result; +} diff --git a/src/io/io.h b/src/io/io.h new file mode 100644 index 0000000..d46f8b1 --- /dev/null +++ b/src/io/io.h @@ -0,0 +1,32 @@ + +/* + * io.h + * + * Communication between PSSE and the outside world, via libcurl. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_io_h +#define __psse_io_h + +URL_FILE *file_to_url_file( FILE * f ); +wint_t url_fgetwc( URL_FILE * input ); +wint_t url_ungetwc( wint_t wc, URL_FILE * input ); + +struct cons_pointer +lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer +lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer +lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer +lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); + + +#endif diff --git a/src/memory/conspage.c b/src/memory/conspage.c index eee6d2d..54d14e9 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -45,9 +45,12 @@ struct cons_pointer freelist = NIL; struct cons_page *conspages[NCONSPAGES]; /** - * Make a cons page whose serial number (i.e. index in the conspages directory) is pageno. - * Initialise all cells and prepend each to the freelist; if pageno is zero, do not prepend - * cells 0 and 1 to the freelist but initialise them as NIL and T respectively. + * Make a cons page. Initialise all cells and prepend each to the freelist; + * if `initialised_cons_pages` is zero, do not prepend cells 0 and 1 to the + * freelist but initialise them as NIL and T respectively. + * \todo we ought to handle cons space exhaustion more gracefully than just + * crashing; should probably return an exception instead, although obviously + * that exception would have to have been pre-built. */ void make_cons_page( ) { struct cons_page *result = malloc( sizeof( struct cons_page ) ); @@ -110,11 +113,11 @@ void make_cons_page( ) { } /** - * dump the allocated pages to this output stream. + * dump the allocated pages to this `output` stream. */ -void dump_pages( FILE * output ) { +void dump_pages( URL_FILE * output ) { for ( int i = 0; i < initialised_cons_pages; i++ ) { - fwprintf( output, L"\nDUMPING PAGE %d\n", i ); + url_fwprintf( output, L"\nDUMPING PAGE %d\n", i ); for ( int j = 0; j < CONSPAGESIZE; j++ ) { dump_object( output, ( struct cons_pointer ) { @@ -125,8 +128,9 @@ void dump_pages( FILE * output ) { } /** - * Frees the cell at the specified pointer. Dangerous, primitive, low - * level. + * Frees the cell at the specified `pointer`; for all the types of cons-space + * object which point to other cons-space objects, cascade the decrement. + * Dangerous, primitive, low level. * * @pointer the cell to free */ @@ -136,60 +140,66 @@ void free_cell( struct cons_pointer 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. */ - case CONSTV: - dec_ref( cell->payload.cons.car ); - dec_ref( cell->payload.cons.cdr ); - break; - case EXCEPTIONTV: - dec_ref( cell->payload.exception.message ); - dec_ref( cell->payload.exception.frame ); - break; - case FUNCTIONTV: - dec_ref( cell->payload.function.source ); - break; - case LAMBDATV: - case NLAMBDATV: - 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; - case STRINGTV: - 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 0x%lx\n", - cell->payload.vectorp.address ); - struct vector_space_object *vso = cell->payload.vectorp.address; - - switch ( vso->header.tag.value ) { - case STACKFRAMETV: - free_stack_frame(get_stack_frame(pointer)); - break; - } - - free( ( void * ) cell->payload.vectorp.address ); - debug_printf( DEBUG_ALLOC, - L"Freed vector-space object at 0x%lx\n", - cell->payload.vectorp.address ); - break; - - } - if ( !check_tag( pointer, FREETAG ) ) { if ( cell->count == 0 ) { + switch ( cell->tag.value ) { + case CONSTV: + dec_ref( cell->payload.cons.car ); + dec_ref( cell->payload.cons.cdr ); + break; + case EXCEPTIONTV: + dec_ref( cell->payload.exception.message ); + dec_ref( cell->payload.exception.frame ); + break; + case FUNCTIONTV: + dec_ref( cell->payload.function.source ); + break; + case INTEGERTV: + dec_ref( cell->payload.integer.more ); + break; + case LAMBDATV: + case NLAMBDATV: + 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 READTV: + case WRITETV: + url_fclose( cell->payload.stream.stream); + break; + case SPECIALTV: + dec_ref( cell->payload.special.source ); + break; + case STRINGTV: + 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 0x%lx\n", + cell->payload.vectorp.address ); + struct vector_space_object *vso = + cell->payload.vectorp.address; + + switch ( vso->header.tag.value ) { + case STACKFRAMETV: + free_stack_frame( get_stack_frame( pointer ) ); + break; + } + + free( ( void * ) cell->payload.vectorp.address ); + debug_printf( DEBUG_ALLOC, + L"Freed vector-space object at 0x%lx\n", + cell->payload.vectorp.address ); + break; + + } + strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); cell->payload.free.car = NIL; cell->payload.free.cdr = freelist; @@ -207,11 +217,14 @@ void free_cell( struct cons_pointer pointer ) { } /** - * Allocates a cell with the specified tag. Dangerous, primitive, low + * Allocates a cell with the specified `tag`. Dangerous, primitive, low * level. * * @param tag the tag of the cell to allocate - must be a valid cons space tag. * @return the cons pointer which refers to the cell allocated. + * \todo handle the case where another cons_page cannot be allocated; + * return an exception. Which, as we cannot create such an exception when + * cons space is exhausted, means we must construct it at init time. */ struct cons_pointer allocate_cell( char *tag ) { struct cons_pointer result = freelist; diff --git a/src/memory/conspage.h b/src/memory/conspage.h index bc1361e..fa11da9 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -9,7 +9,7 @@ * to) is the maximum value of an unsigned 32 bit integer, which is to * say 4294967296. However, we'll start small. */ -#define CONSPAGESIZE 8 +#define CONSPAGESIZE 1024 /** * the number of cons pages we will initially allow for. For @@ -25,7 +25,7 @@ * of addressable memory, which is only slightly more than the * number of atoms in the universe. */ -#define NCONSPAGES 8 +#define NCONSPAGES 64 /** * a cons page is essentially just an array of cons space objects. It @@ -37,42 +37,16 @@ struct cons_page { struct cons_space_object cell[CONSPAGESIZE]; }; -/** - * The (global) pointer to the (global) freelist. Not sure whether this ultimately - * belongs in this file. - */ extern struct cons_pointer freelist; -/** - * An array of pointers to cons pages. - */ extern struct cons_page *conspages[NCONSPAGES]; -/** - * Frees the cell at the specified pointer. Dangerous, primitive, low - * level. - * - * @pointer the cell to free - */ void free_cell( struct cons_pointer pointer ); -/** - * Allocates a cell with the specified tag. Dangerous, primitive, low - * level. - * - * @param tag the tag of the cell to allocate - must be a valid cons space tag. - * @return the cons pointer which refers to the cell allocated. - */ struct cons_pointer allocate_cell( char *tag ); -/** - * initialise the cons page system; to be called exactly once during startup. - */ void initialise_cons_pages( ); -/** - * dump the allocated pages to this output stream. - */ -void dump_pages( FILE * output ); +void dump_pages( URL_FILE * output ); #endif diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 6f89742..9edbf66 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -25,9 +25,9 @@ #include "stack.h" /** - * Check that the tag on the cell at this pointer is this tag + * True if the tag on the cell at this `pointer` is this `tag`, else false. */ -int check_tag( struct cons_pointer pointer, char *tag ) { +bool check_tag( struct cons_pointer pointer, char *tag ) { struct cons_space_object cell = pointer2cell( pointer ); return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; } @@ -95,8 +95,6 @@ struct cons_pointer make_exception( struct cons_pointer message, 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; @@ -178,12 +176,12 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { inc_ref( tail ); cell->payload.string.character = c; cell->payload.string.cdr.page = tail.page; - /* TODO: There's a problem here. Sometimes the offsets on + /* \todo There's a problem here. Sometimes the offsets on * strings are quite massively off. Fix is probably * cell->payload.string.cdr = tsil */ cell->payload.string.cdr.offset = tail.offset; } else { - // TODO: should throw an exception! + // \todo should throw an exception! debug_printf( DEBUG_ALLOC, L"Warning: only NIL and %s can be prepended to %s\n", tag, tag ); @@ -193,17 +191,23 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { } /** - * Construct a string from this character and - * this tail. A string is implemented as a flat list of cells each of which - * has one character and a pointer to the next; in the last cell the - * pointer to next is NIL. + * Construct a string from the character `c` and this `tail`. A string is + * implemented as a flat list of cells each of which has one character and a + * pointer to the next; in the last cell the pointer to next is NIL. + * + * @param c the character to add (prepend); + * @param tail the string which is being built. */ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { return make_string_like_thing( c, tail, STRINGTAG ); } /** - * Construct a symbol from this character and this tail. + * Construct a symbol from the character `c` and this `tail`. A symbol is + * internally identical to a string except for having a different tag. + * + * @param c the character to add (prepend); + * @param tail the symbol which is being built. */ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { return make_string_like_thing( c, tail, SYMBOLTAG ); @@ -229,7 +233,7 @@ make_special( struct cons_pointer src, struct cons_pointer ( *executable ) * Construct a cell which points to a stream open for reading. * @param input the C stream to wrap. */ -struct cons_pointer make_read_stream( FILE * input ) { +struct cons_pointer make_read_stream( URL_FILE * input ) { struct cons_pointer pointer = allocate_cell( READTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -239,10 +243,10 @@ struct cons_pointer make_read_stream( FILE * input ) { } /** - * Construct a cell which points to a stream open for writeing. + * Construct a cell which points to a stream open for writing. * @param output the C stream to wrap. */ -struct cons_pointer make_write_stream( FILE * output ) { +struct cons_pointer make_write_stream( URL_FILE * output ) { struct cons_pointer pointer = allocate_cell( WRITETAG ); struct cons_space_object *cell = &pointer2cell( pointer ); diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 523fdaa..6230e64 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -1,4 +1,4 @@ -/** +/* * consspaceobject.h * * Declarations common to all cons space objects. @@ -17,6 +17,8 @@ #include #include +#include "fopen.h" + #ifndef __consspaceobject_h #define __consspaceobject_h @@ -25,119 +27,189 @@ */ #define TAGLENGTH 4 -/** - * tag values, all of which must be 4 bytes. Must not collide with vector space tag values +/* + * tag values, all of which must be 4 bytes. Must not collide with vector space + * tag values */ /** - * A word within a bignum - arbitrary precision integer. - */ -#define BIGNUMTAG "BIGN" -#define BIGNUMTV 1313294658 - -/** - * An ordinary cons cell: 1397641027 + * An ordinary cons cell: */ #define CONSTAG "CONS" + +/** + * The string `CONS`, considered as an `unsigned int`. + */ #define CONSTV 1397641027 /** * An exception. */ #define EXCEPTIONTAG "EXEP" + +/** + * The string `EXEP`, considered as an `unsigned int`. + */ #define EXCEPTIONTV 1346721861 /** * An unallocated cell on the free list - should never be encountered by a Lisp - * function. 1162170950 + * function. */ #define FREETAG "FREE" + +/** + * The string `FREE`, considered as an `unsigned int`. + */ #define FREETV 1162170950 /** - * An ordinary Lisp function - one whose arguments are pre-evaluated and passed as - * a stack frame. 1129207110 + * An ordinary Lisp function - one whose arguments are pre-evaluated. + * \see LAMBDATAG for interpretable functions. + * \see SPECIALTAG for functions whose arguments are not pre-evaluated. */ #define FUNCTIONTAG "FUNC" -#define FUNCTIONTV 1129207110 + /** - * An integer number. 1381256777 + * The string `FUNC`, considered as an `unsigned int`. + */ +#define FUNCTIONTV 1129207110 + +/** + * An integer number (bignums are integers). */ #define INTEGERTAG "INTR" + +/** + * The string `INTR`, considered as an `unsigned int`. + */ #define INTEGERTV 1381256777 /** - * A lambda cell. + * A lambda cell. Lambdas are the interpretable (source) versions of functions. + * \see FUNCTIONTAG. */ #define LAMBDATAG "LMDA" + +/** + * The string `LMDA`, considered as an `unsigned int`. + */ #define LAMBDATV 1094995276 /** - * The special cons cell at address {0,0} whose car and cdr both point to itself. - * 541870414 + * The special cons cell at address {0,0} whose car and cdr both point to + * itself. */ #define NILTAG "NIL " + +/** + * The string `NIL `, considered as an `unsigned int`. + */ #define NILTV 541870414 /** - * An nlambda cell. + * An nlambda cell. NLambdas are the interpretable (source) versions of special + * forms. \see SPECIALTAG. */ #define NLAMBDATAG "NLMD" + +/** + * The string `NLMD`, considered as an `unsigned int`. + */ #define NLAMBDATV 1145916494 +/** + * A rational number, stored as pointers two integers representing dividend + * and divisor respectively. + */ +#define RATIOTAG "RTIO" + +/** + * The string `RTIO`, considered as an `unsigned int`. + */ +#define RATIOTV 1330205778 + /** * An open read stream. */ #define READTAG "READ" + +/** + * The string `READ`, considered as an `unsigned int`. + */ #define READTV 1145128274 /** - * A real number. + * A real number, represented internally as an IEEE 754-2008 `binary64`. */ #define REALTAG "REAL" + +/** + * The string `REAL`, considered as an `unsigned int`. + */ #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 + * A special form - one whose arguments are not pre-evaluated but passed as + * provided. + * \see NLAMBDATAG. */ #define SPECIALTAG "SPFM" + +/** + * The string `SPFM`, considered as an `unsigned int`. + */ #define SPECIALTV 1296453715 /** - * A string of characters, organised as a linked list. 1196577875 + * A string of characters, organised as a linked list. */ #define STRINGTAG "STRG" + +/** + * The string `STRG`, considered as an `unsigned int`. + */ #define STRINGTV 1196577875 /** - * A symbol is just like a string except not self-evaluating. 1112365395 + * A symbol is just like a string except not self-evaluating. */ #define SYMBOLTAG "SYMB" + +/** + * The string `SYMB`, considered as an `unsigned int`. + */ #define SYMBOLTV 1112365395 /** - * The special cons cell at address {0,1} which is canonically different from NIL. - * 1163219540 + * The special cons cell at address {0,1} which is canonically different + * from NIL. */ #define TRUETAG "TRUE" + +/** + * The string `TRUE`, considered as an `unsigned int`. + */ #define TRUETV 1163219540 /** * A pointer to an object in vector space. */ #define VECTORPOINTTAG "VECP" + +/** + * The string `VECP`, considered as an `unsigned int`. + */ #define VECTORPOINTTV 1346585942 + /** * An open write stream. */ #define WRITETAG "WRIT" + +/** + * The string `WRIT`, considered as an `unsigned int`. + */ #define WRITETV 1414091351 /** @@ -160,101 +232,103 @@ */ #define tag2uint(tag) ((uint32_t)*tag) +/** + * given a cons_pointer as argument, return the cell. + */ #define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset])) /** - * true if conspointer points to the special cell NIL, else false + * true if `conspoint` points to the special cell NIL, else false * (there should only be one of these so it's slightly redundant). */ #define nilp(conspoint) (check_tag(conspoint,NILTAG)) /** - * true if conspointer points to a cons cell, else false - */ -#define bignump(conspoint) (check_tag(conspoint,BIGNUMTAG)) - -/** - * true if conspointer points to a cons cell, else false + * true if `conspoint` points to a cons cell, else false */ #define consp(conspoint) (check_tag(conspoint,CONSTAG)) /** - * true if conspointer points to an exception, else false + * true if `conspoint` points to an exception, else false */ #define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTAG)) /** - * true if conspointer points to a function cell, else false + * true if `conspoint` points to a function cell, else false */ #define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG)) /** - * true if conspointer points to a special Lambda cell, else false + * true if `conspoint` points to a special Lambda cell, else false */ #define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG)) /** - * true if conspointer points to a special form cell, else false + * true if `conspoint` points to a special form cell, else false */ #define specialp(conspoint) (check_tag(conspoint,SPECIALTAG)) /** - * true if conspointer points to a string cell, else false + * true if `conspoint` points to a string cell, else false */ #define stringp(conspoint) (check_tag(conspoint,STRINGTAG)) /** - * true if conspointer points to a symbol cell, else false + * true if `conspoint` points to a symbol cell, else false */ #define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG)) /** - * true if conspointer points to an integer cell, else false + * true if `conspoint` points to an integer cell, else false */ #define integerp(conspoint) (check_tag(conspoint,INTEGERTAG)) /** - * true if conspointer points to a rational number cell, else false + * true if `conspoint` points to a rational number cell, else false */ #define ratiop(conspoint) (check_tag(conspoint,RATIOTAG)) /** - * true if conspointer points to a read stream cell, else false + * true if `conspoint` points to a read stream cell, else false */ #define readp(conspoint) (check_tag(conspoint,READTAG)) /** - * true if conspointer points to a real number cell, else false + * true if `conspoint` points to a real number cell, else false */ #define realp(conspoint) (check_tag(conspoint,REALTAG)) /** - * true if conspointer points to some sort of a number cell, + * true if `conspoint` points to some sort of a number cell, * else false */ #define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG)) +/** + * true if `conspoint` points to a sequence (list, string or, later, vector), + * else false. + */ #define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG)) /** - * true if thr conspointer points to a vector pointer. + * true if `conspoint` points to a vector pointer, else false. */ #define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTAG)) /** - * true if conspointer points to a write stream cell, else false. + * true if `conspoint` points to a write stream cell, else false. */ #define writep(conspoint) (check_tag(conspoint,WRITETAG)) /** - * true if conspointer points to a true cell, else false + * true if `conspoint` points to a true cell, else false * (there should only be one of these so it's slightly redundant). * Also note that anything that is not NIL is truthy. */ #define tp(conspoint) (checktag(conspoint,TRUETAG)) /** - * true if conspoint points to something that is truthy, i.e. + * true if `conspoint` points to something that is truthy, i.e. * anything but NIL. */ #define truep(conspoint) (!checktag(conspoint,NILTAG)) @@ -276,34 +350,28 @@ struct cons_pointer { /** * A stack frame. Yes, I know it isn't a cons-space object, but it's defined - * here to avoid circularity. TODO: refactor. + * here to avoid circularity. \todo refactor. */ struct stack_frame { - struct cons_pointer previous; /* the previous frame */ + /** the previous frame. */ + struct cons_pointer previous; + /** first 8 arument bindings. */ 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 */ + /** list of any further argument bindings. */ + struct cons_pointer more; + /** the function to be called. */ + struct cons_pointer function; + /** the number of arguments provided. */ 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. */ struct cons_payload { + /** Contents of the Address Register, naturally. */ struct cons_pointer car; + /** Contents of the Decrement Register, naturally. */ struct cons_pointer cdr; }; @@ -312,7 +380,9 @@ struct cons_payload { * Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame. */ struct exception_payload { + /** The message: should be a Lisp string but in practice anything printable will do. */ struct cons_pointer message; + /** pointer to the (unfreed) stack frame in which the exception was thrown. */ struct cons_pointer frame; }; @@ -326,7 +396,17 @@ struct exception_payload { * result). */ struct function_payload { + /** + * pointer to the source from which the function was compiled, or NIL + * if it is a primitive. + */ struct cons_pointer source; + /** pointer to a function which takes a cons pointer (representing + * 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). + * \todo check this documentation is current! + */ struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ); @@ -342,27 +422,37 @@ struct free_payload { }; /** - * payload of an integer cell. For the time being just a signed integer; - * later might be a signed 128 bit integer, or might have some flag to point to an - * optional bignum object. + * payload of an integer cell. An integer is in principle a sequence of cells; + * only 60 bits (+ sign bit) are actually used in each cell. If the value + * exceeds 60 bits, the least significant 60 bits are stored in the first cell + * in the chain, the next 60 in the next cell, and so on. Only the value of the + * first cell in any chain should be negative. */ struct integer_payload { + /** the value of the payload (i.e. 60 bits) of this cell. */ int64_t value; + /** the next (more significant) cell in the chain, ir `NIL` if there are no + * more. */ + struct cons_pointer more; }; /** - * payload for lambda and nlambda cells + * payload for lambda and nlambda cells. */ struct lambda_payload { + /** the arument list */ struct cons_pointer args; + /** the body of the function to be applied to the arguments. */ struct cons_pointer body; }; /** - * payload for ratio cells. Both dividend and divisor must point to integer (or, later, bignum) cells. + * payload for ratio cells. Both `dividend` and `divisor` must point to integer cells. */ struct ratio_payload { + /** a pointer to an integer representing the dividend */ struct cons_pointer dividend; + /** a pointer to an integer representing the divisor. */ struct cons_pointer divisor; }; @@ -371,20 +461,25 @@ struct ratio_payload { * precision, but I'm not sure of the detail. */ struct real_payload { + /** the value of the number */ long double value; }; /** - * Payload of a special form cell. - * source points to the source from which the function was compiled, or NIL - * if it is a primitive. - * executable points to a function which takes a cons pointer (representing - * 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). + * Payload of a special form cell. Currently identical to the payload of a + * function cell. + * \see function_payload */ struct special_payload { + /** + * pointer to the source from which the special form was compiled, or NIL + * if it is a primitive. + */ struct cons_pointer source; + /** pointer to a function which takes a cons pointer (representing + * 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). */ struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ); @@ -394,7 +489,12 @@ struct special_payload { * payload of a read or write stream cell. */ struct stream_payload { - FILE *stream; + /** the stream to read from or write to. */ + URL_FILE *stream; + /** metadata on the stream (e.g. its file attributes if a file, its HTTP + * headers if a URL, etc). Expected to be an association, or nil. Not yet + * implemented. */ + struct cons_pointer meta; }; /** @@ -404,8 +504,11 @@ struct stream_payload { * payload of a string cell. */ struct string_payload { - wint_t character; /* the actual character stored in this cell */ - uint32_t padding; /* unused padding to word-align the cdr */ + /** the actual character stored in this cell */ + wint_t character; + /** unused padding to word-align the cdr */ + uint32_t padding; + /** the remainder of the string following this character. */ struct cons_pointer cdr; }; @@ -413,19 +516,21 @@ struct string_payload { * payload of a vector pointer cell. */ struct vectorp_payload { + /** the tag of the vector-space object. NOTE that the vector space object + * should itself have the identical tag. */ 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 */ + /** the tag (type) of the vector-space object this cell + * points to, considered as bytes. */ + char bytes[TAGLENGTH]; + /** the tag considered as a number */ + uint32_t value; } tag; - void *address; - /* the address of the actual vector space - * object (TODO: will change when I actually + /** unused padding to word-align the address */ + uint32_t padding; + /** the address of the actual vector space + * object (\todo will change when I actually * implement vector space) */ + void *address; }; /** @@ -433,87 +538,80 @@ struct vectorp_payload { */ struct cons_space_object { union { - char bytes[TAGLENGTH]; /* the tag (type) of this cell, - * considered as bytes */ - uint32_t value; /* the tag considered as a number */ + /** the tag (type) of this cell, + * considered as bytes */ + char bytes[TAGLENGTH]; + /** the tag considered as a number */ + uint32_t value; } tag; - uint32_t count; /* the count of the number of references to - * this cell */ - struct cons_pointer access; /* cons pointer to the access control list of - * this cell */ + /** the count of the number of references to this cell */ + uint32_t count; + /** cons pointer to the access control list of this cell */ + struct cons_pointer access; union { - /* + /** * if tag == CONSTAG */ struct cons_payload cons; - /* + /** * if tag == EXCEPTIONTAG */ struct exception_payload exception; - /* + /** * if tag == FREETAG */ struct free_payload free; - /* + /** * if tag == FUNCTIONTAG */ struct function_payload function; - /* + /** * if tag == INTEGERTAG */ struct integer_payload integer; - /* + /** * if tag == LAMBDATAG or NLAMBDATAG */ struct lambda_payload lambda; - /* + /** * 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 */ struct stream_payload stream; - /* + /** * if tag == REALTAG */ struct real_payload real; - /* + /** * if tag == SPECIALTAG */ struct special_payload special; - /* + /** * if tag == STRINGTAG || tag == SYMBOLTAG */ struct string_payload string; - /* + /** * if tag == TRUETAG; we'll treat the special cell T as just a cons */ struct cons_payload t; - /* + /** * if tag == VECTORPTAG */ struct vectorp_payload vectorp; } payload; }; -/** - * Check that the tag on the cell at this pointer is this tag - */ -int check_tag( struct cons_pointer pointer, char *tag ); +bool check_tag( struct cons_pointer pointer, char *tag ); -/** - * increment the reference count of the object at this cons pointer - */ void inc_ref( struct cons_pointer pointer ); -/** - * decrement the reference count of the object at this cons pointer - */ void dec_ref( struct cons_pointer pointer ); struct cons_pointer make_cons( struct cons_pointer car, @@ -522,71 +620,34 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer frame_pointer ); -/** - * Construct a cell which points to an executable Lisp special form. - */ struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ); -/** - * Construct a lambda (interpretable source) cell - */ struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer body ); -/** - * Construct an nlambda (interpretable source) cell; to a - * lambda as a special form is to a function. - */ 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 ) ); -/** - * Construct a string from this character and this tail. A string is - * implemented as a flat list of cells each of which has one character and a - * pointer to the next; in the last cell the pointer to next is NIL. - */ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); -/** - * Construct a symbol from this character and this tail. A symbol is identical - * to a string except for having a different tag. - */ struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ); -/** - * Construct a cell which points to a stream open for reading. - * @param input the C stream to wrap. - */ -struct cons_pointer make_read_stream( FILE * input ); +struct cons_pointer make_read_stream( URL_FILE * input ); -/** - * Construct a cell which points to a stream open for writeing. - * @param output the C stream to wrap. - */ -struct cons_pointer make_write_stream( FILE * output ); +struct cons_pointer make_write_stream( URL_FILE * output ); - -/** - * Return a lisp string representation of this old skool ASCII 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( wchar_t *symbol ); #endif diff --git a/src/memory/dump.c b/src/memory/dump.c index d3a53d3..e99d306 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -26,94 +26,99 @@ #include "vectorspace.h" -void dump_string_cell( FILE * output, wchar_t *prefix, +void dump_string_cell( URL_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 ); + url_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: " ); + url_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 ); + url_fwprintf( output, L"\t\t value: " ); print( output, pointer ); - fwprintf( output, L"\n" ); + url_fwprintf( output, L"\n" ); } } /** * dump the object at this cons_pointer to this output stream. */ -void dump_object( FILE * output, struct cons_pointer pointer ) { +void dump_object( URL_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 ); + url_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 ); + url_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 ); + url_fputws( L"\n", output ); break; case EXCEPTIONTV: - fwprintf( output, L"\t\tException cell: " ); + url_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 ); + url_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 ); + url_fwprintf( output, + L"\t\tInteger cell: value %ld, count %u\n", + cell.payload.integer.value, cell.count ); + if ( !nilp( cell.payload.integer.more ) ) { + url_fputws( L"\t\tBIGNUM! More at:\n", output ); + dump_object( output, cell.payload.integer.more ); + } break; case LAMBDATV: - fwprintf( output, L"\t\tLambda cell;\n\t\t args: " ); + url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); print( output, cell.payload.lambda.args ); - fwprintf( output, L";\n\t\t\tbody: " ); + url_fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); break; case NILTV: break; case NLAMBDATV: - fwprintf( output, L"\t\tNlambda cell; \n\t\targs: " ); + url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); print( output, cell.payload.lambda.args ); - fwprintf( output, L";\n\t\t\tbody: " ); + url_fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); 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 ); + url_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" ); + url_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 ); + url_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 ); @@ -124,14 +129,14 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { case TRUETV: break; case VECTORPOINTTV:{ - fwprintf( output, - L"\t\tPointer to vector-space object at %p\n", - cell.payload.vectorp.address ); + url_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 ); + url_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 ); } @@ -143,7 +148,7 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { } break; case WRITETV: - fwprintf( output, L"\t\tOutput stream\n" ); + url_fwprintf( output, L"\t\tOutput stream\n" ); break; } } diff --git a/src/memory/dump.h b/src/memory/dump.h index e49f453..f8ef75f 100644 --- a/src/memory/dump.h +++ b/src/memory/dump.h @@ -1,4 +1,4 @@ -/** +/* * dump.h * * Dump representations of both cons space and vector space objects. @@ -20,10 +20,6 @@ #define __dump_h -/** - * dump the object at this cons_pointer to this output stream. - */ -void dump_object( FILE * output, struct cons_pointer pointer ); - +void dump_object( URL_FILE * output, struct cons_pointer pointer ); #endif diff --git a/src/memory/stack.c b/src/memory/stack.c index da4c17d..3f4a271 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -26,14 +26,22 @@ #include "stack.h" #include "vectorspace.h" +/** + * set a register in a stack frame. Alwaye use this to do so, + * because that way we can be sure the inc_ref happens! + */ 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; + dec_ref( frame->arg[reg] ); /* if there was anything in that slot + * previously other than NIL, we need to decrement it; + * NIL won't be decremented as it is locked. */ + frame->arg[reg] = value; inc_ref( value ); - if ( reg > frame->args ) { - frame->args = reg; + + if ( reg == frame->args ) { + frame->args++; } } @@ -71,15 +79,10 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { 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 + * \todo later, pop a frame off a free-list of stack frames */ frame->previous = previous; @@ -131,7 +134,7 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, struct cons_space_object cell = pointer2cell( args ); /* - * TODO: if we were running on real massively parallel hardware, + * \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 @@ -220,16 +223,16 @@ struct cons_pointer make_special_frame( struct cons_pointer previous, */ void free_stack_frame( struct stack_frame *frame ) { /* - * TODO: later, push it back on the stack-frame freelist + * \todo later, push it back on the stack-frame freelist */ - debug_print(L"Entering free_stack_frame\n", DEBUG_ALLOC); + debug_print( L"Entering free_stack_frame\n", DEBUG_ALLOC ); for ( int i = 0; i < args_in_frame; i++ ) { dec_ref( frame->arg[i] ); } if ( !nilp( frame->more ) ) { dec_ref( frame->more ); } - debug_print(L"Leaving free_stack_frame\n", DEBUG_ALLOC); + debug_print( L"Leaving free_stack_frame\n", DEBUG_ALLOC ); } @@ -238,34 +241,34 @@ void free_stack_frame( struct stack_frame *frame ) { * @param output the stream * @param frame_pointer the pointer to the frame */ -void dump_frame( FILE * output, struct cons_pointer frame_pointer ) { +void dump_frame( URL_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 ); + url_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 ); + url_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 ); + url_fputws( L"\n", output ); } if ( !nilp( frame->more ) ) { - fputws( L"More: \t", output ); + url_fputws( L"More: \t", output ); print( output, frame->more ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); } } } -void dump_stack_trace( FILE * output, struct cons_pointer pointer ) { +void dump_stack_trace( URL_FILE * output, struct cons_pointer pointer ) { if ( exceptionp( pointer ) ) { print( output, pointer2cell( pointer ).payload.exception.message ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); dump_stack_trace( output, pointer2cell( pointer ).payload.exception.frame ); } else { diff --git a/src/memory/stack.h b/src/memory/stack.h index 189ff6b..0ea903c 100644 --- a/src/memory/stack.h +++ b/src/memory/stack.h @@ -35,12 +35,6 @@ */ #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 ); @@ -53,9 +47,9 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, void free_stack_frame( struct stack_frame *frame ); -void dump_frame( FILE * output, struct cons_pointer pointer ); +void dump_frame( URL_FILE * output, struct cons_pointer pointer ); -void dump_stack_trace( FILE * output, struct cons_pointer frame_pointer ); +void dump_stack_trace( URL_FILE * output, struct cons_pointer frame_pointer ); struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n ); @@ -65,7 +59,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous, /* * struct stack_frame is defined in consspaceobject.h to break circularity - * TODO: refactor. + * \todo refactor. */ #endif diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index cf0b1d6..480effb 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -26,19 +26,29 @@ /** - * make a cons-space object which points to the vector space object + * 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`. + * + * @address the address of the vector_space_object to point to. + * @tag the vector-space tag of the particular type of vector-space object, + * NOT `VECTORPOINTTAG`. + * + * @return a cons_pointer to the object, or NIL if the object could not be + * allocated due to memory exhaustion. */ -struct cons_pointer make_vec_pointer( struct vector_space_object *address ) { +struct cons_pointer make_vec_pointer( struct vector_space_object *address, + char *tag ) { 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; + strncpy( &cell->payload.vectorp.tag.bytes[0], tag, TAGLENGTH ); + debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n", cell->payload.vectorp.address ); @@ -49,11 +59,15 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address ) { } /** - * allocate a vector space object with this `payload_size` and `tag`, + * 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. + * + * @tag the vector-space tag of the particular type of vector-space object, + * NOT `VECTORPOINTTAG`. + * @payload_size the size of the payload required, in bytes. + * + * @return a cons_pointer to the object, or NIL if the object 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 ); @@ -67,12 +81,12 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { struct vector_space_object *vso = malloc( padded ); if ( vso != NULL ) { - memset(vso, 0, padded); + memset( vso, 0, padded ); 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 ); + result = make_vec_pointer( vso, tag ); debug_dump_object( result, DEBUG_ALLOC ); vso->header.vecp = result; // memcpy(vso->header.vecp, result, sizeof(struct cons_pointer)); diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index 1438d37..22b0d88 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -40,32 +40,48 @@ #define VECTORTAG "VECT" #define VECTORTV 0 +/** + * given a pointer to a vector space object, return the object. + */ #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)) + +/** + * given a vector space object, return its canonical pointer. + */ +#define vso_get_vecp(vso)((((vector_space_object)vso)->header.vecp)) struct cons_pointer make_vso( char *tag, uint64_t payload_size ); +/** + * the header which forms the start of every vector space object. + */ struct vector_space_header { + /** the tag (type) of this vector-space object. */ 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 */ + /** the tag considered as bytes. */ + char bytes[TAGLENGTH]; + /** the tag considered as a number */ + uint32_t value; } 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 */ + /** back pointer to the vector pointer which uniquely points to this vso */ + struct cons_pointer vecp; + /** the size of my payload, in bytes */ + uint64_t size; }; +/** a vector_space_object is just a vector_space_header followed by a + * lump of bytes; what we deem to be in there is a function of the tag, + * and at this stage we don't have a good picture of what these may be. + * + * \see stack_frame for an example payload; + * \see make_empty_frame for an example of how to initialise and use one. + */ struct vector_space_object { + /** the header of this 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. */ + /** we'll malloc `size` bytes for payload, `payload` is just the first of these. + * \todo this is almost certainly not idiomatic C. */ + char payload; }; #endif diff --git a/src/ops/equal.c b/src/ops/equal.c index ebb085e..2775218 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -12,7 +12,7 @@ #include "conspage.h" #include "consspaceobject.h" -#include "integer.h" +#include "peano.h" /** * Shallow, and thus cheap, equality: true if these two objects are @@ -80,18 +80,20 @@ 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 = - cell_a->payload.integer.value == - cell_b->payload.integer.value; + ( cell_a->payload.integer.value == + cell_b->payload.integer.value ) && + equal( cell_a->payload.integer.more, + cell_b->payload.integer.more ); break; case REALTV: { - double num_a = numeric_value( a ); - double num_b = numeric_value( b ); + double num_a = to_long_double( a ); + double num_b = to_long_double( b ); double max = fabs( num_a ) > fabs( num_b ) ? fabs( num_a ) : fabs( num_b ); diff --git a/src/ops/intern.c b/src/ops/intern.c index 29848a7..87d116e 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -27,7 +27,8 @@ #include "print.h" /** - * The object list. What is added to this during system setup is 'global', that is, + * The global object list/or, to put it differently, the root namespace. + * What is added to this during system setup is 'global', that is, * visible to all sessions/threads. What is added during a session/thread is local to * that session/thread (because shallow binding). There must be some way for a user to * make the contents of their own environment persistent between threads but I don't @@ -109,8 +110,8 @@ struct cons_pointer c_assoc( struct cons_pointer key, * with this key/value pair added to the front. */ struct cons_pointer -bind( struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store ) { +set( struct cons_pointer key, struct cons_pointer value, + struct cons_pointer store ) { debug_print( L"Binding ", DEBUG_BIND ); debug_print_object( key, DEBUG_BIND ); debug_print( L" to ", DEBUG_BIND ); @@ -130,9 +131,9 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) { debug_print( L"Entering deep_bind\n", DEBUG_BIND ); struct cons_pointer old = oblist; - oblist = bind( key, value, oblist ); - inc_ref(oblist); - dec_ref(old); + oblist = set( key, value, oblist ); + inc_ref( oblist ); + dec_ref( old ); debug_print( L"Leaving deep_bind\n", DEBUG_BIND ); @@ -152,7 +153,7 @@ intern( struct cons_pointer key, struct cons_pointer environment ) { /* * not currently bound */ - result = bind( key, NIL, environment ); + result = set( key, NIL, environment ); } return result; diff --git a/src/ops/intern.h b/src/ops/intern.h index e940daa..fa17563 100644 --- a/src/ops/intern.h +++ b/src/ops/intern.h @@ -1,14 +1,14 @@ -/** +/* * intern.h * * For now this implements an oblist and shallow binding; local environments can * be consed onto the front of the oblist. Later, this won't do; bindings will happen * in namespaces, which will probably be implemented as hash tables. - * + * * Doctrine is that cons cells are immutable, and life is a lot more simple if they are; * so when a symbol is rebound in the master oblist, what in fact we do is construct * a new oblist without the previous binding but with the new binding. Anything which, - * prior to this action, held a pointer to the old oblist (as all current threads' + * prior to this action, held a pointer to the old oblist (as all current threads' * environments must do) continues to hold a pointer to the old oblist, and consequently * doesn't see the change. This is probably good but does mean you cannot use bindings * on the oblist to signal between threads. @@ -22,42 +22,19 @@ extern struct cons_pointer oblist; -/** - * return the value associated with this key in this store. In the current - * implementation a store is just an assoc list, but in future it might be a - * namespace, a regularity or a homogeneity. - */ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store ); -/** - * Return true if this key is present as a key in this enviroment, defaulting to - * the oblist if no environment is passed. - */ struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer environment ); -/** - * Return a new key/value store containing all the key/value pairs in this store - * with this key/value pair added to the front. - */ -struct cons_pointer bind( struct cons_pointer key, - struct cons_pointer value, - struct cons_pointer store ); +struct cons_pointer set( struct cons_pointer key, + struct cons_pointer value, + struct cons_pointer store ); -/** - * Binds this key to this value in the global oblist, but doesn't affect the - * current environment. May not be useful except in bootstrapping (and even - * there it may not be especially useful). - */ struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ); -/** - * Ensure that a canonical copy of this key is bound in this environment, and - * return that canonical copy. If there is currently no such binding, create one - * with the value NIL. - */ struct cons_pointer intern( struct cons_pointer key, struct cons_pointer environment ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index d94a2ff..1220835 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -31,6 +31,7 @@ #include "equal.h" #include "integer.h" #include "intern.h" +#include "io.h" #include "lispops.h" #include "print.h" #include "read.h" @@ -39,9 +40,9 @@ /* * also to create in this section: * struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env, - struct stack_frame* frame); + * struct stack_frame* frame); * struct cons_pointer lisp_mapcar( struct cons_pointer args, struct cons_pointer env, - struct stack_frame* frame); + * struct stack_frame* frame); * * and others I haven't thought of yet. */ @@ -109,25 +110,39 @@ struct cons_pointer eval_form( struct stack_frame *parent, } /** - * eval all the forms in this `list` in the context of this stack `frame` + * Evaluate all the forms in this `list` in the context of this stack `frame` * and this `env`, and return a list of their values. If the arg passed as - * `list` is not in fact a list, return nil. + * `list` is not in fact a list, return NIL. + * @param frame the stack frame. + * @param list the list of forms to be evaluated. + * @param env the evaluation environment. + * @return a list of the the results of evaluating the forms. */ 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, frame_pointer, c_car( list ), env ), - eval_forms( frame, frame_pointer, c_cdr( list ), - env ) ) : NIL; + struct cons_pointer result = NIL; + + while ( consp( list ) ) { + result = + make_cons( eval_form( frame, frame_pointer, c_car( list ), env ), + result ); + list = c_cdr( list ); + } + + return result; } /** * Return the object list (root namespace). * - * (oblist) + * * (oblist) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the root namespace. */ struct cons_pointer lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -135,9 +150,8 @@ lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, return oblist; } - /** - * used to construct the body for `lambda` and `nlambda` expressions. + * Used to construct the body for `lambda` and `nlambda` expressions. */ struct cons_pointer compose_body( struct stack_frame *frame ) { struct cons_pointer body = frame->more; @@ -157,10 +171,15 @@ struct cons_pointer compose_body( struct stack_frame *frame ) { } /** - * Construct an interpretable function. + * Construct an interpretable function. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs function will be created. + * + * (lambda args body) * * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. * @param env the environment in which it is to be intepreted. + * @return an interpretable function with these `args` and this `body`. */ struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -169,10 +188,15 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * Construct an interpretable special form. + * Construct an interpretable special form. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs special form will be created. + * + * (nlambda args body) * * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. * @param env the environment in which it is to be intepreted. + * @return an interpretable special form with these `args` and this `body`. */ struct cons_pointer lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -195,7 +219,7 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; debug_print( L"eval_lambda called\n", DEBUG_LAMBDA ); - debug_println(DEBUG_LAMBDA); + debug_println( DEBUG_LAMBDA ); struct cons_pointer new_env = env; struct cons_pointer names = cell.payload.lambda.args; @@ -208,19 +232,20 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer name = c_car( names ); struct cons_pointer val = frame->arg[i]; - new_env = bind( name, val, new_env ); + new_env = set( name, val, new_env ); log_binding( name, val ); names = c_cdr( names ); } - inc_ref(new_env); + inc_ref( new_env ); - /* TODO: if there's more than `args_in_frame` arguments, bind those too. */ + /* \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; + /* \todo eval all the things in frame->more */ + struct cons_pointer vals = + eval_forms( frame, frame_pointer, frame->more, env ); for ( int i = args_in_frame - 1; i >= 0; i-- ) { struct cons_pointer val = @@ -232,8 +257,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, } } - new_env = bind( names, vals, new_env ); - inc_ref(new_env); + new_env = set( names, vals, new_env ); + inc_ref( new_env ); } while ( !nilp( body ) ) { @@ -241,21 +266,22 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, body = c_cdr( body ); debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA ); - debug_print_object(sexpr, DEBUG_LAMBDA); - debug_println( DEBUG_LAMBDA); + debug_print_object( sexpr, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); - /* if a result is not the terminal result in the lambda, it's a - * side effect, and needs to be GCed */ - if (!nilp(result)) dec_ref(result); + /* if a result is not the terminal result in the lambda, it's a + * side effect, and needs to be GCed */ + if ( !nilp( result ) ) + dec_ref( result ); result = eval_form( frame, frame_pointer, sexpr, new_env ); } - dec_ref(new_env); + dec_ref( new_env ); debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA ); - debug_print_object( result, DEBUG_LAMBDA); - debug_println(DEBUG_LAMBDA); + debug_print_object( result, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); return result; } @@ -404,17 +430,24 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { /** - * (eval s_expr) + * Function; evaluate the expression which is the first argument in the frame; + * further arguments are ignored. * - * function. - * If s_expr is a number, NIL, or T, returns s_expr. - * If s_expr is an unprotected string, returns the value that s_expr is bound - * to in the evaluation environment (env). - * If s_expr is a list, expects the car to be something that evaluates to a - * function or special form. - * If a function, evaluates all the other top level elements in s_expr and - * passes them in a stack frame as arguments to the function. - * If a special form, passes the cdr of s_expr to the special form as argument. + * * (eval expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return + * * If `expression` is a number, string, `nil`, or `t`, returns `expression`. + * * If `expression` is a symbol, returns the value that expression is bound + * to in the evaluation environment (`env`). + * * If `expression` is a list, expects the car to be something that evaluates to a + * function or special form: + * * If a function, evaluates all the other top level elements in `expression` and + * passes them in a stack frame as arguments to the function; + * * If a special form, passes the cdr of expression to the special form as argument. + * @exception if `expression` is a symbol which is not bound in `env`. */ struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -449,12 +482,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, } break; /* - * TODO: + * \todo * the Clojure practice of having a map serve in the function place of - * an s-expression is a good one and I should adopt it; also if the - * object is a consp it could be interpretable source code but in the - * long run I don't want an interpreter, and if I can get away without - * so much the better. + * an s-expression is a good one and I should adopt it; */ default: result = frame->arg[0]; @@ -469,19 +499,23 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (apply fn args) - * - * function. Apply the function which is the result of evaluating the - * first argoment to the list of arguments which is the result of evaluating + * Function; apply the function which is the result of evaluating the + * first argument to the list of values which is the result of evaluating * the second argument + * + * * (apply fn args) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return the result of applying `fn` to `args`. */ struct cons_pointer 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 + debug_dump_object( frame_pointer, DEBUG_EVAL ); + set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); set_reg( frame, 1, NIL ); @@ -495,11 +529,16 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (quote a) - * - * Special form - * Returns its argument (strictly first argument - only one is expected but + * Special form; + * returns its argument (strictly first argument - only one is expected but * this isn't at this stage checked) unevaluated. + * + * * (quote a) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `a`, unevaluated, */ struct cons_pointer lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -509,13 +548,19 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (set name value) - * (set name value namespace) - * - * Function. + * Function; + * binds the value of `name` in the `namespace` to value of `value`, altering + * the namespace in so doing. Retuns `value`. * `namespace` defaults to the oblist. - * Binds the value of `name` in the `namespace` to value of `value`, altering - * the namespace in so doing. `namespace` defaults to the value of `oblist`. + * \todo doesn't actually work yet for namespaces which are not the oblist. + * + * * (set name value) + * * (set name value namespace) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `value` */ struct cons_pointer lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -541,20 +586,25 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (set! symbol value) - * (set! symbol value namespace) + * Special form; + * binds `symbol` in the `namespace` to value of `value`, altering + * the namespace in so doing, and returns value. `namespace` defaults to + * the value of `oblist`. + * \todo doesn't actually work yet for namespaces which are not the oblist. * - * Special form. - * `namespace` defaults to the oblist. - * Binds `symbol` in the `namespace` to value of `value`, altering - * the namespace in so doing. `namespace` defaults to the value of `oblist`. + * * (set! symbol value) + * * (set! symbol value namespace) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `value` */ struct cons_pointer 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]; + struct cons_pointer namespace = frame->arg[2]; if ( symbolp( frame->arg[0] ) ) { struct cons_pointer val = @@ -574,12 +624,27 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (cons a b) - * - * Function. - * Returns a cell constructed from a and b. If a is of type string but its + * @return true if `arg` represents an end of string, else false. + * \todo candidate for moving to a memory/string.c file + */ +bool end_of_stringp( struct cons_pointer arg ) { + return nilp( arg ) || + ( stringp( arg ) && + pointer2cell( arg ).payload.string.character == ( wint_t ) '\0' ); +} + +/** + * Function; + * returns a cell constructed from a and b. If a is of type string but its * cdr is nill, and b is of type string, then returns a new string cell; * otherwise returns a new cons cell. + * + * * (cons a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return a new cons cell whose `car` is `a` and whose `cdr` is `b`. */ struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -591,7 +656,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( nilp( car ) && nilp( cdr ) ) { return NIL; } else if ( stringp( car ) && stringp( cdr ) && - nilp( pointer2cell( car ).payload.string.cdr ) ) { + end_of_stringp( c_cdr( car ) ) ) { + // \todo check that car is of length 1 result = make_string( pointer2cell( car ).payload.string.character, cdr ); } else { @@ -602,58 +668,100 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (car s_expr) - * Returns the first item (head) of a sequence. Valid for cons cells, - * strings, and TODO read streams and other things which can be considered as sequences. + * Function; + * returns the first item (head) of a sequence. Valid for cons cells, + * strings, read streams and TODO other things which can be considered as sequences. + * + * * (car expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the first item (head) of `expression`. + * @exception if `expression` is not a sequence. */ struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); - if ( consp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = cell.payload.cons.car; - } else if ( stringp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = make_string( cell.payload.string.character, NIL ); - } else { - struct cons_pointer message = - c_string_to_lisp_string( L"Attempt to take CAR of non sequence" ); - result = throw_exception( message, frame_pointer ); + switch ( cell.tag.value ) { + case CONSTV: + result = cell.payload.cons.car; + break; + case READTV: + result = + make_string( url_fgetwc( cell.payload.stream.stream ), NIL ); + break; + case NILTV: + break; + case STRINGTV: + result = make_string( cell.payload.string.character, NIL ); + break; + default: + result = + throw_exception( c_string_to_lisp_string + ( L"Attempt to take CAR of non sequence" ), + frame_pointer ); } return result; } /** - * (cdr s_expr) - * Returns the remainder of a sequence when the head is removed. Valid for cons cells, - * strings, and TODO read streams and other things which can be considered as sequences. + * Function; + * returns the remainder of a sequence when the head is removed. Valid for cons cells, + * strings, read streams and TODO other things which can be considered as sequences. + * *NOTE* that if the argument is an input stream, the first character is removed AND + * DISCARDED. + * + * * (cdr expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the remainder of `expression` when the head is removed. + * @exception if `expression` is not a sequence. */ struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); - if ( consp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = cell.payload.cons.cdr; - } else if ( stringp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = cell.payload.string.cdr; - } else { - struct cons_pointer message = - c_string_to_lisp_string( L"Attempt to take CDR of non sequence" ); - result = throw_exception( message, frame_pointer ); + switch ( cell.tag.value ) { + case CONSTV: + result = cell.payload.cons.cdr; + break; + case READTV: + url_fgetwc( cell.payload.stream.stream ); + result = frame->arg[0]; + break; + case STRINGTV: + result = cell.payload.string.cdr; + break; + case NILTV: + break; + default: + result = + throw_exception( c_string_to_lisp_string + ( L"Attempt to take CDR of non sequence" ), + frame_pointer ); } return result; } /** - * (assoc key store) - * Returns the value associated with key in store, or NIL if not found. + * Function; look up the value of a `key` in a `store`. + * + * * (assoc key store) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the value associated with `key` in `store`, or `nil` if not found. */ struct cons_pointer lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -662,8 +770,14 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (eq a b) - * Returns T if a and b are pointers to the same object, else NIL + * Function; are these two objects the same object? Shallow, cheap equality. + * + * * (eq a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `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, @@ -672,8 +786,14 @@ struct cons_pointer lisp_eq( struct stack_frame *frame, } /** - * (eq a b) - * Returns T if a and b are pointers to structurally identical objects, else NIL + * Function; are these two arguments identical? Deep, expensive equality. + * + * * (equal a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `t` if `a` and `b` are recursively identical, else `nil`. */ struct cons_pointer lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -681,11 +801,38 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; } + /** - * (read) - * (read read-stream) - * Read one complete lisp form and return it. If read-stream is specified and - * is a read stream, then read from that stream, else stdin. + * Resutn the current default input, or of `inputp` is false, output stream from + * this `env`ironment. + */ +struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer stream_name = + c_string_to_lisp_symbol( inputp ? L"*in*" : L"*out*" ); + + inc_ref( stream_name ); + + result = c_assoc( stream_name, env ); + + dec_ref( stream_name ); + + return result; +} + + +/** + * Function; read one complete lisp form and return it. If read-stream is specified and + * is a read stream, then read from that stream, else the stream which is the value of + * `*in*` in the environment. + * + * * (read) + * * (read read-stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return the expression read. */ struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -693,16 +840,31 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, #ifdef DEBUG debug_print( L"entering lisp_read\n", DEBUG_IO ); #endif - FILE *input = stdin; + URL_FILE *input; - if ( readp( frame->arg[0] ) ) { - input = pointer2cell( frame->arg[0] ).payload.stream.stream; + struct cons_pointer in_stream = readp( frame->arg[0] ) ? + frame->arg[0] : get_default_stream( true, env ); + + if ( readp( in_stream ) ) { + debug_print( L"lisp_read: setting input stream\n", DEBUG_IO ); + debug_dump_object( in_stream, DEBUG_IO ); + input = pointer2cell( in_stream ).payload.stream.stream; + inc_ref( in_stream ); + } else { + input = file_to_url_file( stdin ); } struct cons_pointer result = read( frame, frame_pointer, input ); debug_print( L"lisp_read returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); + if ( readp( in_stream ) ) { + dec_ref( in_stream ); + } else { + free( input ); + } + + return result; } @@ -733,8 +895,14 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) { /** - * (reverse sequence) - * Return a sequence like this sequence but with the members in the reverse order. + * Function; reverse the order of members in s sequence. + * + * * (reverse sequence) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @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, @@ -744,23 +912,36 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, /** - * (print expr) - * (print expr write-stream) - * Print one complete lisp form and return NIL. If write-stream is specified and - * is a write stream, then print to that stream, else stdout. + * Function; print one complete lisp expression and return NIL. If write-stream is specified and + * is a write stream, then print to that stream, else the stream which is the value of + * `*out*` in the environment. + * + * * (print expr) + * * (print expr write-stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the value of `expr`. */ struct cons_pointer 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; + URL_FILE *output; + struct cons_pointer out_stream = writep( frame->arg[1] ) ? + frame->arg[1] : get_default_stream( false, env ); - if ( writep( frame->arg[1] ) ) { + if ( writep( out_stream ) ) { 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_dump_object( out_stream, DEBUG_IO ); + output = pointer2cell( out_stream ).payload.stream.stream; + inc_ref( out_stream ); + } else { + output = file_to_url_file( stderr ); } + debug_print( L"lisp_print: about to print\n", DEBUG_IO ); debug_dump_object( frame->arg[0], DEBUG_IO ); @@ -769,15 +950,25 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_print( L"lisp_print returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); + if ( writep( out_stream ) ) { + dec_ref( out_stream ); + } else { + free( output ); + } + return result; } /** - * Function: Get the Lisp type of the single argument. - * @param frame My stack frame. - * @param env My environment (ignored). - * @return As a Lisp string, the tag of the object which is the argument. + * Function: get the Lisp type of the single argument. + * + * * (type expression) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return As a Lisp string, the tag of `expression`. */ struct cons_pointer lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -785,46 +976,74 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, return c_type( frame->arg[0] ); } +/** + * Evaluate each of these expressions in this `env`ironment over this `frame`, + * returning only the value of the last. + */ +struct cons_pointer +c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer expressions, struct cons_pointer env ) { + struct cons_pointer result = NIL; + + while ( consp( expressions ) ) { + struct cons_pointer r = result; + inc_ref( r ); + result = eval_form( frame, frame_pointer, c_car( expressions ), env ); + dec_ref( r ); + + expressions = c_cdr( expressions ); + } + + return result; +} + /** - * (progn forms...) - * - * Special form; evaluate the forms which are listed in my arguments + * Special form; evaluate the expressions which are listed in my arguments * sequentially and return the value of the last. This function is called 'do' * in some dialects of Lisp. * - * @param frame My stack frame. - * @param env My environment (ignored). - * @return the value of the last form on the sequence which is my single + * * (progn expressions...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which expressions are evaluated. + * @return the value of the last `expression` of the sequence which is my single * argument. */ struct cons_pointer 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++ ) { + struct cons_pointer r = result; + inc_ref( r ); + result = eval_form( frame, frame_pointer, frame->arg[i], env ); + + dec_ref( r ); } - while ( consp( remaining ) ) { - result = eval_form( frame, frame_pointer, c_car( remaining ), env ); - - remaining = c_cdr( remaining ); + if ( consp( frame->more ) ) { + result = c_progn( frame, frame_pointer, frame->more, env ); } return result; } /** - * Special form: conditional. Each arg is expected to be a list; if the first + * Special form: conditional. Each `clause` is expected to be a list; if the first * item in such a list evaluates to non-NIL, the remaining items in that list - * are evaluated in turn and the value of the last returned. If no arg (clause) + * are evaluated in turn and the value of the last returned. If no arg `clause` * has a first element which evaluates to non NIL, then NIL is returned. - * @param frame My stack frame. - * @param env My environment (ignored). - * @return the value of the last form of the first successful clause. + * + * * (cond clauses...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which arguments will be evaluated. + * @return the value of the last expression of the first successful `clause`. */ struct cons_pointer lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -844,15 +1063,9 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, env ); if ( !nilp( result ) ) { - struct cons_pointer vals = - eval_forms( frame, frame_pointer, c_cdr( clause_pointer ), - env ); - - while ( consp( vals ) ) { - result = c_car( vals ); - vals = c_cdr( vals ); - } - + result = + c_progn( frame, frame_pointer, c_cdr( clause_pointer ), + env ); done = true; } } else if ( nilp( clause_pointer ) ) { @@ -863,7 +1076,7 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, frame_pointer ); } } - /* TODO: if there are more than 8 clauses we need to continue into the + /* \todo if there are more than 8 clauses we need to continue into the * remainder */ return result; @@ -898,9 +1111,18 @@ throw_exception( struct cons_pointer message, } /** - * (exception ) + * Function; create an exception. Exceptions are special in as much as if an + * exception is created in the binding of the arguments of any function, the + * function will return the exception rather than whatever else it would + * normally return. A function which detects a problem it cannot resolve + * *should* return an exception. * - * Function. Returns an exception whose message is this `message`, and whose + * * (exception message frame) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which arguments will be evaluated. + * @return areturns 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. @@ -913,3 +1135,184 @@ lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, return exceptionp( message ) ? message : make_exception( message, frame->previous ); } + +/** + * Function: the read/eval/print loop. + * + * * (repl) + * * (repl prompt) + * * (repl prompt input_stream output_stream) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which epressions will be evaluated. + * @return the value of the last expression read. + */ +struct cons_pointer lisp_repl( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer expr = NIL; + + /* \todo bind *prompt*, *input*, *output* in the environment to the values + * of arguments 0, 1, and 2 respectively, but in each case only if the + * argument is not nil */ + + struct cons_pointer input = get_default_stream( true, env ); + struct cons_pointer output = get_default_stream( false, env ); + URL_FILE *os = pointer2cell( output ).payload.stream.stream; + struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); + struct cons_pointer old_oblist = oblist; + struct cons_pointer new_env = env; + inc_ref( env ); + + inc_ref( input ); + inc_ref( output ); + inc_ref( prompt_name ); + + /* \todo this is subtly wrong. If we were evaluating + * (print (eval (read))) + * then the stack frame for read would have the stack frame for + * eval as parent, and it in turn would have the stack frame for + * print as parent. + */ + while ( readp( input ) && writep( output ) + && !url_feof( pointer2cell( input ).payload.stream.stream ) ) { + /* OK, here's a really subtle problem: because lists are immutable, anything + * bound in the oblist subsequent to this function being invoked isn't in the + * environment. So, for example, changes to *prompt* or *log* made in the oblist + * are not visible. So copy changes made in the oblist into the enviroment. + * \todo the whole process of resolving symbol values needs to be revisited + * when we get onto namespaces. */ + if ( !eq( oblist, old_oblist ) ) { + struct cons_pointer cursor = oblist; + + while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { + struct cons_pointer old_new_env = new_env; + debug_print + ( L"lisp_repl: copying new oblist binding into REPL environment:\n", + DEBUG_REPL ); + debug_print_object( c_car( cursor ), DEBUG_REPL ); + debug_println( DEBUG_REPL ); + + new_env = make_cons( c_car( cursor ), new_env ); + inc_ref( new_env ); + dec_ref( old_new_env ); + cursor = c_cdr( cursor ); + } + old_oblist = oblist; + } + + println( os ); + + struct cons_pointer prompt = c_assoc( prompt_name, new_env ); + if ( !nilp( prompt ) ) { + print( os, prompt ); + } + + expr = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, + new_env ); + inc_ref( expr ); + + if ( exceptionp( expr ) + && url_feof( pointer2cell( input ).payload.stream.stream ) ) { + /* suppress printing end of stream exception */ + break; + } + + println( os ); + + print( os, eval_form( frame, frame_pointer, expr, new_env ) ); + + dec_ref( expr ); + } + + dec_ref( input ); + dec_ref( output ); + dec_ref( prompt_name ); + dec_ref( env ); + + return expr; +} + +/** + * Function. return the source code of the object which is its first argument, + * if it is an executable and has source code. + * + * * (source object) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment (ignored). + * @return the source of the `object` indicated, if it is a function, a lambda, + * an nlambda, or a spcial form; else `nil`. + */ +struct cons_pointer lisp_source( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); + + switch ( cell.tag.value ) { + case FUNCTIONTV: + result = cell.payload.function.source; + break; + case SPECIALTV: + result = cell.payload.special.source; + break; + case LAMBDATV: + result = make_cons( c_string_to_lisp_symbol( L"lambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + break; + case NLAMBDATV: + result = make_cons( c_string_to_lisp_symbol( L"nlambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + break; + } + // \todo suffers from premature GC, and I can't see why! + inc_ref( result ); + + return result; +} + + +/** + * Function; print the internal representation of the object indicated by `frame->arg[0]` to the + * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`. + * + * * (inspect expression) + * * (inspect expression ) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment. + * @return the value of the first argument - `expression`. + */ +struct cons_pointer lisp_inspect( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"Entering print\n", DEBUG_IO ); + URL_FILE *output; + struct cons_pointer out_stream = writep( frame->arg[1] ) ? + frame->arg[1] : get_default_stream( false, env ); + + if ( writep( out_stream ) ) { + debug_print( L"lisp_print: setting output stream\n", DEBUG_IO ); + debug_dump_object( out_stream, DEBUG_IO ); + output = pointer2cell( out_stream ).payload.stream.stream; + inc_ref( out_stream ); + } else { + output = file_to_url_file( stdout ); + } + + dump_object( output, frame->arg[0] ); + + if ( writep( out_stream ) ) { + dec_ref( out_stream ); + } else { + free( output ); + } + + return frame->arg[0]; +} diff --git a/src/ops/lispops.h b/src/ops/lispops.h index a1dee81..1aff486 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -140,9 +140,13 @@ struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +struct cons_pointer lisp_repl( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + /** * Function: Get the Lisp type of the single argument. * @param frame My stack frame. @@ -193,3 +197,11 @@ struct cons_pointer throw_exception( struct cons_pointer message, struct cons_pointer lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + +struct cons_pointer lisp_source( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_inspect( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); diff --git a/src/ops/print.c b/src/ops/print.c index 6c0c6e7..8cb137e 100644 --- a/src/ops/print.c +++ b/src/ops/print.c @@ -25,7 +25,7 @@ /** * Whether or not we colorise output. - * TODO: this should be a Lisp symbol binding, not a C variable. + * \todo this should be a Lisp symbol binding, not a C variable. */ int print_use_colours = 0; @@ -34,13 +34,13 @@ int print_use_colours = 0; * onto this `output`; if `pointer` does not indicate a string or symbol, * don't print anything but just return. */ -void print_string_contents( FILE * output, struct cons_pointer pointer ) { +void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) { while ( stringp( pointer ) || symbolp( pointer ) ) { struct cons_space_object *cell = &pointer2cell( pointer ); wchar_t c = cell->payload.string.character; if ( c != '\0' ) { - fputwc( c, output ); + url_fputwc( c, output ); } pointer = cell->payload.string.cdr; } @@ -51,10 +51,10 @@ void print_string_contents( FILE * output, struct cons_pointer pointer ) { * the stream at this `output`, prepending and appending double quote * characters. */ -void print_string( FILE * output, struct cons_pointer pointer ) { - fputwc( btowc( '"' ), output ); +void print_string( URL_FILE * output, struct cons_pointer pointer ) { + url_fputwc( btowc( '"' ), output ); print_string_contents( output, pointer ); - fputwc( btowc( '"' ), output ); + url_fputwc( btowc( '"' ), output ); } /** @@ -63,14 +63,14 @@ void print_string( FILE * output, struct cons_pointer pointer ) { * a space character. */ void -print_list_contents( FILE * output, struct cons_pointer pointer, +print_list_contents( URL_FILE * output, struct cons_pointer pointer, bool initial_space ) { struct cons_space_object *cell = &pointer2cell( pointer ); switch ( cell->tag.value ) { case CONSTV: if ( initial_space ) { - fputwc( btowc( ' ' ), output ); + url_fputwc( btowc( ' ' ), output ); } print( output, cell->payload.cons.car ); @@ -79,23 +79,23 @@ print_list_contents( FILE * output, struct cons_pointer pointer, case NILTV: break; default: - fwprintf( output, L" . " ); + url_fwprintf( output, L" . " ); print( output, pointer ); } } -void print_list( FILE * output, struct cons_pointer pointer ) { +void print_list( URL_FILE * output, struct cons_pointer pointer ) { if ( print_use_colours ) { - fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" ); + url_fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" ); } else { - fputws( L"(", output ); + url_fputws( L"(", output ); }; print_list_contents( output, pointer, false ); if ( print_use_colours ) { - fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" ); + url_fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" ); } else { - fputws( L")", output ); + url_fputws( L")", output ); } } @@ -104,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`. */ -struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { +struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); char *buffer; @@ -117,56 +117,60 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { print_list( output, pointer ); break; case EXCEPTIONTV: - fwprintf( output, L"\n%sException: ", - print_use_colours ? "\x1B[31m" : "" ); + url_fwprintf( output, L"\n%sException: ", + print_use_colours ? "\x1B[31m" : "" ); dump_stack_trace( output, pointer ); break; case FUNCTIONTV: - fwprintf( output, L"(Function)" ); + url_fwprintf( output, L"" ); break; - case INTEGERTV: - if ( print_use_colours ) { - fputws( L"\x1B[34m", output ); + case INTEGERTV:{ + struct cons_pointer s = integer_to_string( pointer, 10 ); + inc_ref( s ); + if ( print_use_colours ) { + url_fputws( L"\x1B[34m", output ); + } + print_string_contents( output, s ); + dec_ref( s ); } - fwprintf( output, L"%ld%", cell.payload.integer.value ); break; - case LAMBDATV: { - struct cons_pointer to_print = make_cons( c_string_to_lisp_symbol( L"lambda" ), - make_cons( cell.payload.lambda.args, - cell.payload. - lambda.body )); - inc_ref(to_print); + case LAMBDATV:{ + struct cons_pointer to_print = + make_cons( c_string_to_lisp_symbol( L"lambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + inc_ref( to_print ); - print( output, to_print ); + print( output, to_print ); - dec_ref(to_print); - } + dec_ref( to_print ); + } break; case NILTV: - fwprintf( output, L"nil" ); + url_fwprintf( output, L"nil" ); break; - case NLAMBDATV: { - struct cons_pointer to_print = make_cons( c_string_to_lisp_symbol( L"nlambda" ), - make_cons( cell.payload.lambda.args, - cell.payload. - lambda.body )); - inc_ref(to_print); + case NLAMBDATV:{ + struct cons_pointer to_print = + make_cons( c_string_to_lisp_symbol( L"nlambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + inc_ref( to_print ); - print( output, to_print ); + print( output, to_print ); - dec_ref(to_print); - } + dec_ref( to_print ); + } break; case RATIOTV: print( output, cell.payload.ratio.dividend ); - fputws( L"/", output ); + url_fputws( L"/", output ); print( output, cell.payload.ratio.divisor ); break; case READTV: - fwprintf( output, L"(Input stream)" ); + url_fwprintf( output, L"" ); break; case REALTV: - /* TODO: using the C heap is a bad plan because it will fragment. + /* \todo using the C heap is a bad plan because it will fragment. * As soon as I have working vector space I'll use a special purpose * vector space object */ buffer = ( char * ) malloc( 24 ); @@ -179,31 +183,31 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { } } if ( print_use_colours ) { - fputws( L"\x1B[34m", output ); + url_fputws( L"\x1B[34m", output ); } - fwprintf( output, L"%s", buffer ); + url_fwprintf( output, L"%s", buffer ); free( buffer ); break; case STRINGTV: if ( print_use_colours ) { - fputws( L"\x1B[36m", output ); + url_fputws( L"\x1B[36m", output ); } print_string( output, pointer ); break; case SYMBOLTV: if ( print_use_colours ) { - fputws( L"\x1B[1;33m", output ); + url_fputws( L"\x1B[1;33m", output ); } print_string_contents( output, pointer ); break; case SPECIALTV: - fwprintf( output, L"(Special form)" ); + url_fwprintf( output, L"" ); break; case TRUETV: - fwprintf( output, L"t" ); + url_fwprintf( output, L"t" ); break; case WRITETV: - fwprintf( output, L"(Output stream)" ); + url_fwprintf( output, L"" ); break; default: fwprintf( stderr, @@ -215,8 +219,12 @@ struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { } if ( print_use_colours ) { - fputws( L"\x1B[39m", output ); + url_fputws( L"\x1B[39m", output ); } return pointer; } + +void println( URL_FILE * output ) { + url_fputws( L"\n", output ); +} diff --git a/src/ops/print.h b/src/ops/print.h index 1399db4..f59f090 100644 --- a/src/ops/print.h +++ b/src/ops/print.h @@ -14,7 +14,8 @@ #ifndef __print_h #define __print_h -struct cons_pointer print( FILE * output, struct cons_pointer pointer ); +struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ); +void println( URL_FILE * output ); extern int print_use_colours; #endif diff --git a/src/ops/read.c b/src/ops/read.c index 69de893..69899c0 100644 --- a/src/ops/read.c +++ b/src/ops/read.c @@ -22,7 +22,9 @@ #include "dump.h" #include "integer.h" #include "intern.h" +#include "io.h" #include "lispops.h" +#include "peano.h" #include "print.h" #include "ratio.h" #include "read.h" @@ -37,13 +39,13 @@ struct cons_pointer read_number( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input, wint_t initial, + URL_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 ); + struct cons_pointer frame_pointer, + URL_FILE * input, wint_t initial ); +struct cons_pointer read_string( URL_FILE * input, wint_t initial ); +struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ); /** * quote reader macro in C (!) @@ -60,23 +62,25 @@ struct cons_pointer c_quote( struct cons_pointer arg ) { */ struct cons_pointer read_continuation( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input, wint_t initial ) { + URL_FILE * input, wint_t initial ) { debug_print( L"entering read_continuation\n", DEBUG_IO ); struct cons_pointer result = NIL; wint_t c; for ( c = initial; - c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) ); + c == '\0' || iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input ) ); - if ( feof( input ) ) { + if ( url_feof( input ) ) { result = throw_exception( c_string_to_lisp_string ( L"End of file while reading" ), frame_pointer ); } else { switch ( c ) { case ';': - for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) ); + for ( c = url_fgetwc( input ); c != '\n'; + c = url_fgetwc( input ) ); /* skip all characters from semi-colon to the end of the line */ break; case EOF: @@ -88,18 +92,19 @@ struct cons_pointer read_continuation( struct stack_frame *frame, result = c_quote( read_continuation ( frame, frame_pointer, input, - fgetwc( input ) ) ); + url_fgetwc( input ) ) ); break; case '(': result = - read_list( frame, frame_pointer, input, fgetwc( input ) ); + read_list( frame, frame_pointer, input, + url_fgetwc( input ) ); break; case '"': - result = read_string( input, fgetwc( input ) ); + result = read_string( input, url_fgetwc( input ) ); break; case '-':{ - wint_t next = fgetwc( input ); - ungetwc( next, input ); + wint_t next = url_fgetwc( input ); + url_ungetwc( next, input ); if ( iswdigit( next ) ) { result = read_number( frame, frame_pointer, input, c, @@ -111,23 +116,24 @@ struct cons_pointer read_continuation( struct stack_frame *frame, break; case '.': { - wint_t next = fgetwc( input ); + wint_t next = url_fgetwc( input ); if ( iswdigit( next ) ) { - ungetwc( next, input ); + url_ungetwc( next, input ); result = read_number( frame, frame_pointer, input, c, true ); } else if ( iswblank( next ) ) { - /* dotted pair. TODO: this isn't right, we + /* dotted pair. \todo this isn't right, we * really need to backtrack up a level. */ result = read_continuation( frame, frame_pointer, input, - fgetwc( input ) ); + url_fgetwc( input ) ); } else { read_symbol( input, c ); } } break; + //case ':': reserved for keywords and paths default: if ( iswdigit( c ) ) { result = @@ -152,81 +158,106 @@ struct cons_pointer read_continuation( struct stack_frame *frame, /** * 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. + * \todo Need to do a lot of inc_ref and dec_ref, to make sure the + * garbage is collected. */ struct cons_pointer read_number( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input, + URL_FILE * input, wint_t initial, bool seen_period ) { debug_print( L"entering read_number\n", DEBUG_IO ); - struct cons_pointer result = NIL; - int64_t accumulator = 0; - int64_t dividend = 0; + + struct cons_pointer result = make_integer( 0, NIL ); + /* \todo we really need to be getting `base` from a privileged Lisp name - + * and it should be the same privileged name we use when writing numbers */ + struct cons_pointer base = make_integer( 10, NIL ); + struct cons_pointer dividend = NIL; int places_of_decimals = 0; wint_t c; - bool negative = initial == btowc( '-' ); + bool neg = initial == btowc( '-' ); - if ( negative ) { - initial = fgetwc( input ); + if ( neg ) { + initial = url_fgetwc( input ); } debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial ); for ( c = initial; iswdigit( c ) - || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) { - if ( c == btowc( '.' ) ) { - if ( seen_period || dividend != 0 ) { - return 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; + || c == L'.' || c == L'/' || c == L','; c = url_fgetwc( input ) ) { + switch ( c ) { + case L'.': + if ( seen_period || !nilp( dividend ) ) { + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: too many periods" ), + frame_pointer ); + } else { + debug_print( L"read_number: decimal point seen\n", + DEBUG_IO ); + seen_period = true; + } + break; + case L'/': + if ( seen_period || !nilp( dividend ) ) { + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: dividend of rational must be integer" ), + frame_pointer ); + } else { + debug_print( L"read_number: ratio slash seen\n", + DEBUG_IO ); + dividend = result; - accumulator = 0; - } - } else { - accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); + result = make_integer( 0, NIL ); + } + break; + case L',': + // silently ignore it. + break; + default: + result = add_integers( multiply_integers( result, base ), + make_integer( ( int ) c - ( int ) '0', + NIL ) ); - debug_printf( DEBUG_IO, - L"Added character %c, accumulator now %ld\n", - c, accumulator ); + debug_printf( DEBUG_IO, + L"read_number: added character %c, result now ", + c ); + debug_print_object( result, DEBUG_IO ); + debug_print( L"\n", DEBUG_IO ); - if ( seen_period ) { - places_of_decimals++; - } + if ( seen_period ) { + places_of_decimals++; + } } } /* * push back the character read which was not a digit */ - ungetwc( c, input ); + url_ungetwc( c, input ); + if ( seen_period ) { - long double rv = ( long double ) - ( accumulator / pow( 10, places_of_decimals ) ); - 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: converting result to real\n", DEBUG_IO ); + struct cons_pointer div = make_ratio( frame_pointer, result, + make_integer( powl + ( to_long_double + ( base ), + places_of_decimals ), + NIL ) ); + inc_ref( div ); + + result = make_real( to_long_double( div ) ); + + dec_ref( div ); + } else if ( integerp( dividend ) ) { + debug_print( L"read_number: converting result to ratio\n", DEBUG_IO ); + result = make_ratio( frame_pointer, dividend, result ); + } + + if ( neg ) { + debug_print( L"read_number: converting result to negative\n", + DEBUG_IO ); + + result = negative( frame_pointer, result ); } debug_print( L"read_number returning\n", DEBUG_IO ); @@ -241,7 +272,7 @@ struct cons_pointer read_number( struct stack_frame *frame, */ struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input, wint_t initial ) { + URL_FILE * input, wint_t initial ) { struct cons_pointer result = NIL; if ( initial != ')' ) { debug_printf( DEBUG_IO, @@ -252,7 +283,7 @@ struct cons_pointer read_list( struct stack_frame *frame, result = make_cons( car, read_list( frame, frame_pointer, input, - fgetwc( input ) ) ); + url_fgetwc( input ) ) ); } else { debug_print( L"End of list detected\n", DEBUG_IO ); } @@ -267,26 +298,30 @@ struct cons_pointer read_list( struct stack_frame *frame, * so delimited in which case it may not contain whitespace (unless escaped) * but may contain a double quote character (probably not a good idea!) */ -struct cons_pointer read_string( FILE * input, wint_t initial ) { +struct cons_pointer read_string( URL_FILE * input, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; switch ( initial ) { case '\0': - result = make_string( initial, NIL ); + result = NIL; break; case '"': + /* making a string of the null character means we can have an empty + * string. Just returning NIL here would make an empty string + * impossible. */ result = make_string( '\0', NIL ); break; default: result = - make_string( initial, read_string( input, fgetwc( input ) ) ); + make_string( initial, + read_string( input, url_fgetwc( input ) ) ); break; } return result; } -struct cons_pointer read_symbol( FILE * input, wint_t initial ) { +struct cons_pointer read_symbol( URL_FILE * input, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; switch ( initial ) { @@ -298,30 +333,31 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { * THIS IS NOT A GOOD IDEA, but is legal */ result = - make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); + make_symbol( initial, + read_symbol( input, url_fgetwc( input ) ) ); break; case ')': /* - * unquoted strings may not include right-parenthesis + * symbols may not include right-parenthesis; */ - result = make_symbol( '\0', NIL ); + result = NIL; /* * push back the character read */ - ungetwc( initial, input ); + url_ungetwc( initial, input ); break; default: if ( iswprint( initial ) && !iswblank( initial ) ) { result = make_symbol( initial, - read_symbol( input, fgetwc( input ) ) ); + read_symbol( input, url_fgetwc( input ) ) ); } else { result = NIL; /* * push back the character read */ - ungetwc( initial, input ); + url_ungetwc( initial, input ); } break; } @@ -338,6 +374,7 @@ struct cons_pointer read_symbol( FILE * input, wint_t initial ) { struct cons_pointer read( struct stack_frame *frame, struct cons_pointer frame_pointer, - FILE * input ) { - return read_continuation( frame, frame_pointer, input, fgetwc( input ) ); + URL_FILE * input ) { + return read_continuation( frame, frame_pointer, input, + url_fgetwc( input ) ); } diff --git a/src/ops/read.h b/src/ops/read.h index c6dbba3..64f36b0 100644 --- a/src/ops/read.h +++ b/src/ops/read.h @@ -15,6 +15,7 @@ * read the next object on this input stream and return a cons_pointer to it. */ struct cons_pointer read( struct stack_frame *frame, - struct cons_pointer frame_pointer, FILE * input ); + struct cons_pointer frame_pointer, + URL_FILE * input ); #endif diff --git a/src/repl.c b/src/repl.c index d07df94..0ea104d 100644 --- a/src/repl.c +++ b/src/repl.c @@ -11,118 +11,28 @@ #include #include -#include "conspage.h" #include "consspaceobject.h" #include "debug.h" #include "intern.h" #include "lispops.h" -#include "read.h" -#include "print.h" #include "stack.h" -/* TODO: this is subtly wrong. If we were evaluating - * (print (eval (read))) - * then the stack frame for read would have the stack frame for - * eval as parent, and it in turn would have the stack frame for - * print as parent. - */ - /** - * Dummy up a Lisp read call with its own stack frame. + * The read/eval/print loop. */ -struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { - 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 ); +void repl( ) { + debug_print( L"Entered repl\n", DEBUG_REPL ); + + struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, oblist ); + if ( !nilp( frame_pointer ) ) { inc_ref( frame_pointer ); - result = - lisp_read( get_stack_frame( frame_pointer ), frame_pointer, - oblist ); + + lisp_repl( 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; -} - -/** - * Dummy up a Lisp eval call with its own stack frame. - */ -struct cons_pointer repl_eval( struct cons_pointer input ) { - debug_print( L"Entered repl_eval\n", DEBUG_REPL ); - struct cons_pointer result = NIL; - - result = eval_form( NULL, NIL, input, oblist ); - - debug_print( L"repl_eval: returning\n", DEBUG_REPL ); - debug_dump_object( result, DEBUG_REPL ); - - return result; -} - -/** - * Dummy up a Lisp print call with its own stack frame. - */ -struct cons_pointer repl_print( struct cons_pointer stream_pointer, - struct cons_pointer value ) { - 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; -} - -/** - * The read/eval/print loop - * @param in_stream the stream to read from; - * @param out_stream the stream to write to; - * @param err_stream the stream to send errors to; - * @param show_prompt true if prompts should be shown. - */ -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 ); - 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 ); - inc_ref(val); - repl_print( output_stream, val ); - dec_ref(val); - } - - dec_ref( input ); - } - - dec_ref(input_stream); - dec_ref(output_stream); debug_print( L"Leaving repl\n", DEBUG_REPL ); } diff --git a/src/repl.h b/src/repl.h index 1a7b0e9..8ff8b19 100644 --- a/src/repl.h +++ b/src/repl.h @@ -20,13 +20,8 @@ extern "C" { /** * The read/eval/print loop - * @param in_stream the stream to read from; - * @param out_stream the stream to write to; - * @param err_stream the stream to send errors to; - * @param show_prompt true if prompts should be shown. */ - void repl( FILE * in_stream, FILE * out_stream, - FILE * error_stream, bool show_prompt ); + void repl( ); #ifdef __cplusplus } diff --git a/unit-tests/add.sh b/unit-tests/add.sh old mode 100644 new mode 100755 index 4516808..2802c3a --- a/unit-tests/add.sh +++ b/unit-tests/add.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(add 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(add 2 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='5.5' -actual=`echo "(add 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(add 2.5 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -24,7 +24,7 @@ else fi expected='1/4' -actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 3/14 1/28)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -36,7 +36,7 @@ fi # (+ integer ratio) should be ratio expected='25/4' -actual=`echo "(+ 6 1/4)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 6 1/4)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -48,7 +48,7 @@ fi # (+ ratio integer) should be ratio expected='25/4' -actual=`echo "(+ 1/4 6)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 1/4 6)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/apply.sh b/unit-tests/apply.sh old mode 100644 new mode 100755 index 3483fb0..811fdae --- a/unit-tests/apply.sh +++ b/unit-tests/apply.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='1' -actual=`echo "(apply 'add '(1))"| target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(apply 'add '(1))"| target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh new file mode 100755 index 0000000..7bbb41e --- /dev/null +++ b/unit-tests/bignum-add.sh @@ -0,0 +1,228 @@ +#!/bin/bash + +##################################################################### +# add two large numbers, not actally bignums to produce a smallnum +# (right on the boundary) +a=1152921504606846975 +b=1 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking no bignum was created: " +grep -v 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# add two numbers, not actally bignums to produce a bignum +# (just over the boundary) +a='1152921504606846976' +b=1 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + + +##################################################################### +# add a bignum and a smallnum to produce a bignum +# (just over the boundary) +a='1152921504606846977' +b=1 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# add a smallnum and a bignum to produce a bignum +# (just over the boundary) +a=1 +b=1152921504606846977 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + + +##################################################################### +# add two bignums to produce a bignum +a=10000000000000000000 +b=10000000000000000000 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + + +##################################################################### +# add a smallnum and a two-cell bignum to produce a three-cell bignum +# (just over the boundary) +a=1 +b=1329227995784915872903807060280344576 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + + +##################################################################### +# This currently fails: +# (= (+ 1 3064991081731777716716694054300618367237478244367204352) +# 3064991081731777716716694054300618367237478244367204353) +a=1 +b=3064991081731777716716694054300618367237478244367204352 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi diff --git a/unit-tests/bignum-expt.sh b/unit-tests/bignum-expt.sh new file mode 100755 index 0000000..ab9cb24 --- /dev/null +++ b/unit-tests/bignum-expt.sh @@ -0,0 +1,135 @@ +#!/bin/bash + +##################################################################### +# last 'smallnum' value: +# sbcl calculates (expt 2 59) => 576460752303423488 +expected='576460752303423488' + +output=`target/psse < 1152921504606846976 +expected='1152921504606846976' + +output=`target/psse < 2305843009213693952 +expected='2305843009213693952' + +output=`target/psse < 18446744073709551616 +expected='18446744073709551616' + +output=`target/psse < 36893488147419103232 +expected='36893488147419103232' + +output=`target/psse <psse.log` + +actual=`echo $output |\ + sed 's/\,//g' |\ + sed 's/[^0-9]*\([0-9]*\).*/\1/'` + +echo -n "printing $expected: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + +##################################################################### +# right on the boundary +expected='1152921504606846976' +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + sed 's/\,//g' |\ + sed 's/[^0-9]*\([0-9]*\).*/\1/'` + +echo -n "printing $expected: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + +##################################################################### +# definitely a bignum +expected='1152921504606846977' +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + sed 's/\,//g' |\ + sed 's/[^0-9]*\([0-9]*\).*/\1/'` + +echo -n "printing $expected: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + +# Currently failing from here on, but it's failing in read because of +# the multiply bug. We know printing blows up at the 3 cell boundary +# because `lisp/scratchpad2.lisp` constructs a 3 cell bignum by +# repeated addition. +##################################################################### +# Just on the three cell boundary +expected='1329227995784915872903807060280344576' +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + sed 's/\,//g' |\ + sed 's/[^0-9]*\([0-9]*\).*/\1/'` + +echo -n "printing $expected: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', \n got '${actual}'" + exit 1 +fi + +exit 0 + +##################################################################### +# definitely a three cell bignum +expected='1329227995784915872903807060280344577' +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + sed 's/\,//g' |\ + sed 's/[^0-9]*\([0-9]*\).*/\1/'` + +echo -n "printing $expected: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +exit 0 diff --git a/unit-tests/bignum-subtract.sh b/unit-tests/bignum-subtract.sh new file mode 100755 index 0000000..9342913 --- /dev/null +++ b/unit-tests/bignum-subtract.sh @@ -0,0 +1,116 @@ +#!/bin/bash + +##################################################################### +# subtract a smallnum from a smallnum to produce a smallnum +# (right on the boundary) +a=1152921504606846976 +b=1 +expected='1152921504606846975' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking no bignum was created: " +grep -v 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# subtract a smallnum from a bignum to produce a smallnum +# (just over the boundary) +a='1152921504606846977' +b=1 +expected='1152921504606846976' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# subtract a smallnum from a bignum to produce a smallnum +a='1152921504606846978' +b=1 +expected='1152921504606846977' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + +##################################################################### +# subtract a bignum from a smallnum to produce a negstive smallnum +# (just over the boundary) +a=1 +b=1152921504606846977 +expected='-1152921504606846976' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# subtract a bignum from a bignum to produce a bignum +a=20000000000000000000 +b=10000000000000000000 +expected=10000000000000000000 +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + diff --git a/unit-tests/bignum.sh b/unit-tests/bignum.sh new file mode 100755 index 0000000..aa29143 --- /dev/null +++ b/unit-tests/bignum.sh @@ -0,0 +1,14 @@ +#!/bin/bash + +expected='1,152,921,504,606,846,976' +# 1,152,921,504,606,846,975 is the largest single cell positive integer; +# consequently 1,152,921,504,606,846,976 is the first two cell positive integer. +actual=`echo '(+ 1,152,921,504,606,846,975 1)' | target/psse -v 68 2>bignum.log | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh old mode 100644 new mode 100755 index d3728d8..3e84d79 --- a/unit-tests/complex-list.sh +++ b/unit-tests/complex-list.sh @@ -1,7 +1,7 @@ #!/bin/bash -expected='(1 2 3 ("Fred") nil 77354)' -actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse 2> /dev/null | head -2 | tail -1` +expected='(1 2 3 ("Fred") nil 77,354)' +actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/cond.sh b/unit-tests/cond.sh old mode 100644 new mode 100755 index 227f9b3..ab2e2f0 --- a/unit-tests/cond.sh +++ b/unit-tests/cond.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(cond ((equal 2 2) 5))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(cond ((equal 2 2) 5))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='"should"' -actual=`echo "(cond ((equal 2 3) \"shouldn't\")(t \"should\"))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(cond ((equal 2 3) \"shouldn't\")(t \"should\"))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/empty-list.sh b/unit-tests/empty-list.sh old mode 100644 new mode 100755 index 1e24452..8f0f702 --- a/unit-tests/empty-list.sh +++ b/unit-tests/empty-list.sh @@ -1,5 +1,5 @@ #!/bin/bash -# +# # File: empty-list.sh.bash # Author: simon # @@ -7,7 +7,7 @@ # expected=nil -actual=`echo "'()" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'()" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/empty-string.sh b/unit-tests/empty-string.sh old mode 100644 new mode 100755 index 340fd1b..a1e5baa --- a/unit-tests/empty-string.sh +++ b/unit-tests/empty-string.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="\"\"" -actual=`echo '""' | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo '""' | target/psse | tail -1` if [ "$expected" = "$actual" ] then diff --git a/unit-tests/eval-integer.sh b/unit-tests/eval-integer.sh old mode 100644 new mode 100755 index addc133..1aadb39 --- a/unit-tests/eval-integer.sh +++ b/unit-tests/eval-integer.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(eval 5)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(eval 5)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/eval-quote-sexpr.sh b/unit-tests/eval-quote-sexpr.sh old mode 100644 new mode 100755 index eea16ec..d83bbe8 --- a/unit-tests/eval-quote-sexpr.sh +++ b/unit-tests/eval-quote-sexpr.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(eval '(add 2 3))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(eval '(add 2 3))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/eval-quote-symbol.sh b/unit-tests/eval-quote-symbol.sh old mode 100644 new mode 100755 index 5eca83d..7e80c48 --- a/unit-tests/eval-quote-symbol.sh +++ b/unit-tests/eval-quote-symbol.sh @@ -1,7 +1,7 @@ #!/bin/bash -expected='(Special form)' -actual=`echo "(eval 'cond)" | target/psse 2> /dev/null | head -2 | tail -1` +expected='' +actual=`echo "(eval 'cond)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/eval-real.sh b/unit-tests/eval-real.sh old mode 100644 new mode 100755 index 8832719..3aa16d7 --- a/unit-tests/eval-real.sh +++ b/unit-tests/eval-real.sh @@ -5,12 +5,11 @@ expected='5.05' actual=`echo "(eval 5.05)" |\ target/psse 2> /dev/null |\ sed 's/0*$//' |\ - head -2 |\ tail -1` +# one part in a million is close enough... outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc` - if [ "${outcome}" = "1" ] then echo "OK" diff --git a/unit-tests/eval-string.sh b/unit-tests/eval-string.sh old mode 100644 new mode 100755 index 4b8dc8e..90f6f2c --- a/unit-tests/eval-string.sh +++ b/unit-tests/eval-string.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"5"' -actual=`echo '(eval "5")' | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo '(eval "5")' | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/fred.sh b/unit-tests/fred.sh old mode 100644 new mode 100755 index 427c60d..8e3d513 --- a/unit-tests/fred.sh +++ b/unit-tests/fred.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"Fred"' -actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo ${expected} | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/integer-allocation.sh b/unit-tests/integer-allocation.sh old mode 100644 new mode 100755 index c2edf14..ced92f2 --- a/unit-tests/integer-allocation.sh +++ b/unit-tests/integer-allocation.sh @@ -1,8 +1,8 @@ #!/bin/bash value=354 -expected="Integer cell: value ${value}" -echo ${value} | target/psse -v4 2>&1 | grep "${expected}" > /dev/null +expected="Integer cell: value ${value}," +echo ${value} | target/psse -v5 2>&1 | grep "${expected}" > /dev/null if [ $? -eq 0 ] then diff --git a/unit-tests/integer.sh b/unit-tests/integer.sh old mode 100644 new mode 100755 index 41b2da3..18ae66e --- a/unit-tests/integer.sh +++ b/unit-tests/integer.sh @@ -1,7 +1,7 @@ #!/bin/bash -expected="354" -actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` +expected='354' +actual=`echo ${expected} | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/intepreter.sh b/unit-tests/intepreter.sh old mode 100644 new mode 100755 index 9eb2a06..6f23fc9 --- a/unit-tests/intepreter.sh +++ b/unit-tests/intepreter.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='6' -actual=`echo "(apply '(lambda (x y z) (/ (* y z) x)) '(2 3 4))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(apply '(lambda (x y z) (/ (* y z) x)) '(2 3 4))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/lambda.sh b/unit-tests/lambda.sh old mode 100644 new mode 100755 index c1197e0..b7f1707 --- a/unit-tests/lambda.sh +++ b/unit-tests/lambda.sh @@ -1,10 +1,11 @@ #!/bin/bash -expected='(lambda (l) l)(1 2 3 4 5 6 7 8 9 10)' -actual=`target/psse 2>/dev/null </dev/null < /dev/null | head -2 | tail -1` +actual=`echo "(+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +# check that all the args are actually being evaluated... +expected="120" +actual=`echo "(+ (+ 0 1) (+ 0 2) (+ 0 3) (+ 0 4) (+ 0 5) (+ 0 6) (+ 0 7) (+ 0 8) (+ 0 9) (+ 0 10) (+ 0 11) (+ 0 12) (+ 0 13) (+ 0 14 ) (+ 0 15))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then echo "OK" - exit 0 else echo "Fail: expected '${expected}', got '${actual}'" exit 1 diff --git a/unit-tests/multiply.sh b/unit-tests/multiply.sh old mode 100644 new mode 100755 index 0675a6f..94b19f6 --- a/unit-tests/multiply.sh +++ b/unit-tests/multiply.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='6' -actual=`echo "(multiply 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(multiply 2 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='7.5' -actual=`echo "(multiply 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(multiply 2.5 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/nil.sh b/unit-tests/nil.sh old mode 100644 new mode 100755 index de4ef57..fcbf530 --- a/unit-tests/nil.sh +++ b/unit-tests/nil.sh @@ -1,7 +1,7 @@ #!/bin/bash expected=nil -actual=`echo 'nil' | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo 'nil' | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/nlambda.sh b/unit-tests/nlambda.sh old mode 100644 new mode 100755 index f267527..68f0447 --- a/unit-tests/nlambda.sh +++ b/unit-tests/nlambda.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='a' -actual=`echo "((nlambda (x) x) a)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "((nlambda (x) x) a)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/progn.sh b/unit-tests/progn.sh old mode 100644 new mode 100755 index 017646b..352c87a --- a/unit-tests/progn.sh +++ b/unit-tests/progn.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(progn (add 2 3))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(progn (add 2 3))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='"foo"' -actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quote.sh b/unit-tests/quote.sh old mode 100644 new mode 100755 index bded011..78d4ce5 --- a/unit-tests/quote.sh +++ b/unit-tests/quote.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='Fred' -actual=`echo "'Fred" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'Fred" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quoted-list.sh b/unit-tests/quoted-list.sh old mode 100644 new mode 100755 index 24480c6..f69cd75 --- a/unit-tests/quoted-list.sh +++ b/unit-tests/quoted-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(123 (4 (5 nil)) Fred)' -actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/ratio-addition.sh b/unit-tests/ratio-addition.sh old mode 100644 new mode 100755 index f57d0b0..ba93c5d --- a/unit-tests/ratio-addition.sh +++ b/unit-tests/ratio-addition.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='1/4' -actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 3/14 1/28)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/recursion.sh b/unit-tests/recursion.sh old mode 100644 new mode 100755 index a49154b..6b5be2d --- a/unit-tests/recursion.sh +++ b/unit-tests/recursion.sh @@ -1,7 +1,7 @@ #!/bin/bash -expected='nil3628800' -actual=`target/psse 2>/dev/null </dev/null </dev/null < /dev/null | head -2 | tail -1` +actual=`echo '(reverse "The quick brown fox jumped over the lazy dog")' | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -11,8 +11,8 @@ else 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` +expected='(1,024 512 256 128 64 32 16 8 4 2)' +actual=`echo "(reverse '(2 4 8 16 32 64 128 256 512 1024))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -23,7 +23,7 @@ else fi expected='esrever' -actual=`echo "(reverse 'reverse)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(reverse 'reverse)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/simple-list.sh b/unit-tests/simple-list.sh old mode 100644 new mode 100755 index 60492b9..daf3db2 --- a/unit-tests/simple-list.sh +++ b/unit-tests/simple-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="(1 2 3)" -actual=`echo "'(1 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'(1 2 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/slurp.sh b/unit-tests/slurp.sh new file mode 100755 index 0000000..e285988 --- /dev/null +++ b/unit-tests/slurp.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +expected='"Hello, this is used by `slurp.sh` test, please do not remove.' +actual=`echo '(slurp (open "hi"))' | target/psse | tail -2 | head -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + exit 0 +else + echo "Fail: expected '$expected', got '$actual'" + exit 1 +fi diff --git a/unit-tests/string-allocation.sh b/unit-tests/string-allocation.sh old mode 100644 new mode 100755 diff --git a/unit-tests/string-cons.sh b/unit-tests/string-cons.sh new file mode 100755 index 0000000..0ea0a71 --- /dev/null +++ b/unit-tests/string-cons.sh @@ -0,0 +1,25 @@ +#!/bin/bash + +# We should be able to cons a single character string onto the front of a string +expected='"Test"' +actual=`echo '(cons "T" "est")' | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +# But if the first argument has more than one character, we should get a dotted pair +expected='("Test" . "pass")' +actual=`echo '(cons "Test" "pass")' | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/string-with-spaces.sh b/unit-tests/string-with-spaces.sh old mode 100644 new mode 100755 index 384cc9f..0f0f6d0 --- a/unit-tests/string-with-spaces.sh +++ b/unit-tests/string-with-spaces.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"Strings should be able to include spaces (and other stuff)!"' -actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo ${expected} | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/varargs.sh b/unit-tests/varargs.sh old mode 100644 new mode 100755 index 6c31163..27bac3e --- a/unit-tests/varargs.sh +++ b/unit-tests/varargs.sh @@ -1,10 +1,7 @@ #!/bin/bash -expected='(lambda l l)(1 2 3 4 5 6 7 8 9 10)' -actual=`target/psse 2>/dev/null <