- (defn map-world
- "Apply this `function` to each cell in this `world` to produce a new world.
- the arguments to the function will be the world, the cell, and any
- ` additional-args` supplied. Note that we parallel map over rows but
- just map over cells within a row. That's because it isn't worth starting
- a new thread for each cell, but there may be efficiency gains in
- running rows in parallel."
- ([world function]
- (map-world world function nil))
- ([world function additional-args]
- (into []
- (pmap (fn [row]
- (into [] (map
- #(apply function
- (cons world (cons % additional-args)))
- row)))
- world))))
-
-
-As you see, this maps across a two dimensional array, mapping over each of the rows of the array, and, within each row, mapping over each cell in the row. As you can see, in this current version, I parallel map over the rows but serial map over the cells within a row.
-
-Here's why:
-
-## Hybrid parallel/non-parallel version
-
-This is the current default version. It runs at about 650% processor loading - i.e. it maxes out six cores and does some work on a seventh. The eighth core is doing all the Unix housekeeping.
-
- (time (def x1 (utils/map-world
- (utils/map-world w heightmap/tag-altitude (list hm))
- heightmap/tag-gradient)))
- "Elapsed time: 24592.327364 msecs"
- #'mw-explore.optimise/x1
-
-## Pure parallel version
-
-Runs at about 690% processor loading - almost fully using seven cores. But, as you can see, fully one third slower.
-
- (time (def x2 (utils/map-world-p-p
- (utils/map-world-p-p w heightmap/tag-altitude (list hm))
- heightmap/tag-gradient)))
- "Elapsed time: 36762.382725 msecs"
- #'mw-explore.optimise/x2
-
-(For completeness, the *clojure.core.reducers/map* is even slower, so is not discussed in any further detail)
-
-## Non parallel version
-
-Maxes out one single core, takes about 3.6 times as long as the hybrid version. But, in terms of processor cycles, that's a considerable win - because 6.5 cores for 24 seconds is 156 seconds, so there's a 73% overhead in running threads across multiple cores.
-
- (time (def x2 (utils/map-world-n-n
- (utils/map-world-n-n w heightmap/tag-altitude (list hm))
- heightmap/tag-gradient)))
- "Elapsed time: 88412.883849 msecs"
- #'mw-explore.optimise/x2
-
-Now, I need to say a little more about this. It's obvious that there's a considerable set-up/tear-down cost for threads. The reason I'm using *pmap* for the outer mapping but serial *map* for the inner mapping rather than the other way round is to do more work in each thread.
-
-However, I'm still simple-mindedly parallelising the whole of one map operation and serialising the whole of the other. This particular array is 2048 cells square - so over four million cells in total. But, by parallelising the outer map operation, I'm actually asking the operating system for 2048 threads - far more than there are cores. I have tried to write a version of map using [Runtime.getRuntime().availableProcessors()](http://stackoverflow.com/questions/1980832/java-how-to-scale-threads-according-to-cpu-cores) to find the number of processors I have available, and then partitioned the outer array into that number of partitions and ran the parallel map function over that partitioning:
-
- (defn adaptive-map
- "An implementation of `map` which takes note of the number of available cores."
- [fn list]
- (let [cores (.availableProcessors (. Runtime getRuntime ))
- parts (partition-all (/ (count list) cores) list)]
- (apply concat (pmap #(map fn %) parts))))
-
-Sadly, as [A A Milne wrote](http://licoricelaces.livejournal.com/234435.html), 'It's a good sort of brake But it hasn't worked yet.'
-
-But that's not what I came to talk about. I came to talk about the draft...
-
-We are reaching the physical limits of the speed of switching a single processor. That's why our processors now have multiple cores. And they're soon going to have many more cores. Both Oracle ([SPARC](http://www.theregister.co.uk/2014/08/18/oracle_reveals_32core_10_beeellion_transistor_sparc_m7/)) and [ARM](http://www.enterprisetech.com/2014/05/08/arm-server-chips-scale-32-cores-beyond/) are demoing chips with 32 cores, each 64 bits wide, on a single die. [Intel and MIPS are talking about 48 core, 64 bit wide, chips](http://www.cpushack.com/2012/11/18/48-cores-and-beyond-why-more-cores/). A company called [Adapteva is shipping a 64 core by 64 bit chip](http://www.adapteva.com/products/silicon-devices/e64g401/), although I don't know what instruction set family it belongs to. Very soon we will have more; and, even if we don't have more cores on a physical die, we will have motherboards with multiple dies, scaling up the number of processors even further.
-
-# The Challenge
-
-The challenge for software designers - and, specifically, for runtime designers - is to write software which can use these chips reasonably efficiently. But the challenge, it seems to me, for hardware designers, is to design hardware which makes it easy to write software which can use it efficiently.
-
-## Looking for the future in the past, part one
-
-Thinking about this, I have been thinking about the [Connection Machine](http://en.wikipedia.org/wiki/Connection_Machine). I've never really used a Connection Machine, but there was once one in a lab which also contained a Xerox Dandelion I was working on, so I know a little bit about them. A Connection Machine was a massively parallel computer having a very large number - up to 65,536 - of very simple processors (each processor had a register width of one bit). Each processor node had a single LED lamp; when in use, actively computing something, this lamp would be illuminated. So you could see visually how efficient your program was at exploiting the computing resource available.
-
-\[Incidentally while reading up on the Connection Machine I came across this [delightful essay](http://longnow.org/essays/richard-feynman-connection-machine/) on Richard Feynman's involvement in the project - it's of no relevance to my argument here, but nevertheless I commend it to you\]
-
-The machine was programmed in a pure-functional variant of Common Lisp. Unfortunately, I don't know the details of how this worked. As I understand it each processor had its own local memory but there was also a pool of other memory known as 'main RAM'; I'm guessing that each processor's memory was preloaded with a memory image of the complete program to run, so that every processor had local access to all functions; but I don't know this to be true. I don't know how access to main memory was managed, and in particular how contention on access to main memory was managed.
-
-What I do know from reading is that each processor was connected to twenty other processors in a fixed topology known as a hypercube. What I remember from my own observation was that a computation would start with just one or a small number of nodes lit, and flash across the machine as deeply recursive functions exploded from node to node. What I surmise from what I saw is that passing a computation to an unoccupied adjacent node was extremely cheap.
-
-A possibly related machine from the same period which may also be worth studying but about which I know less was the [Meiko Computing Surface](http://www.new-npac.org/projects/cdroms/cewes-1999-06-vol1/nhse/hpccsurvey/orgs/meiko/meiko.html). The Computing Surface was based on the [Transputer T4](http://en.wikipedia.org/wiki/Transputer#T4:_32-bit) processor, a 32 bit processor designed specifically for parallel processing. Each transputer node had its own local store, and very high speed serial links to its four nearest neighbours. As far as I know there was no shared store. The Computing Surface was designed to be programmed in a special purpose language, [Occam](http://en.wikipedia.org/wiki/Occam_(programming_language)). Although I know that Edinburgh University had at one time a Computing Surface with a significant number of nodes, I don't know how many 'a significant number' is. It may have been hundreds of nodes but I'm fairly sure it wasn't thousands. However, each node was of course significantly more powerful than the Connection Machine's one bit nodes.
-
-## A caveat
-
-One of the lessons we learned in those high, far off, arrogant days was that special purpose hardware that could do marvellous things but was expensive lost out to much less capable but cheaper general purpose hardware. There's no point in designing fancy machines unless there's some prospect that they can be mass produced and widely used, because otherwise they will be too expensive to be practical; which presumes not only that they have the potential to be widely used, but also that you (or someone else related to the project) is able to communicate that potential to people with enough money to back the project.
-
-# Hardware for Post Scarcity software
-
-Before going forward with this argument, lets go back. Let's go back to the idea of the Clojure map function. In fact, let's go back to the idea of a function.
-
-If a processor is computing a function, and that function has an argument, then before the function can be computed the value of the argument must be computed; and, as the function cannot be computed until the value of the argument has been computed, there is no point in handing off the processing of the argument to another processor, because the first processor will then necessarily be idle until the value is returned. So it may just as well recurse up the stack itself.
-
-However, if a function has two arguments and values of both must be computed, then if the first processor can hand off processing of one of them to another, similar, processor, potentially the two can be processed in the time in which the original processor could process just one. Provided, that is, that the cost of handing off processing to another processor is substantially less than the cost of evaluating the argument - which is to say, as a general thing, the closer one can get the cost of handing off to another processor to the cost of allocating a stack frame on the current processor, the better. And this is where current-generation hardware is losing out: that cost of handing off is just way too high.
-
-Suppose, then, that our processor is a compute node in a Connection-Machine-like hypercube, able to communicate directly at high speed with twenty close neighbours (I'll come back to this point in detail later). Suppose also that each neighbour-connection has a 'busy' line, which the neighbour raises when it is itself busy. So our processor can see immediately without any need for doing a round-robin which of its neighbours are available to do new work.
-
-Our processor receives a function call with seven arguments, each of which is a further function call. It hands six of these off to idle neighbours, pushes one onto its own local stack, computes it, and recurses back to the original stack frame, waits for the last of the other six to report back a value, and then carries on with its processing.
-
-The fly in the ointment here is memory access. I assume all the processors have significant read-only cache (they don't need read-write cache, we're dealing with immutable data; and they only need a very small amount of scratchpad memory). If all six of the other processors find the data they need (for these purposes the executable function definition is also data) in local cache, all is good, and this will be very fast. But what if all have cache misses, and have to request the data from main memory?
-
-This comes down to topology. I'm not at all clear how you even manage to have twenty separate data channels from a single node. To have a data channel from each node, separately, to main memory simply isn't possible - not if you're dealing with very large numbers of compute nodes. So the data bus has to be literally a bus, available to all nodes simultaneously. Which means, each node that wants some data from main memory must ask for it, and then sit watching the bus, waiting for it to be delivered. Which also means that as data is sent out on the bus, it needs to be tagged with what data it is.
-
-## Looking for the future in the past, part two
-
-In talking about the Connection Machine which lurked in the basement of Logica's central London offices, I mentioned that it lurked in a lab where one of the [Xerox 1108 Dandelions](http://en.wikipedia.org/wiki/Interlisp) I was employed to work on was also located. The Dandelion was an interesting machine in itself. In typical computers - typical modern computers, but also typical computers of thirty years ago - the microcode has virtually the status of hardware. While it may technically be software, it is encoded immutably into the chip when the chip is made, and can never be changed.
-
-The Dandelion and its related machines weren't like that. Physically, the Dandelion was identical to the Star workstations which Xerox then sold for very high end word processing. But it ran different microcode. You could load the microcode; you could even, if you were very daring, write your own microcode. In its Interlisp guise, it had all the core Lisp functions as single opcodes. It had object oriented message passing - with full multiple inheritance and dynamic selector-method resolution - as a single opcode. But it also had another very interesting instruction: [BITBLT](http://en.wikipedia.org/wiki/Bit_blit), or 'Bit Block Transfer'.
-
-This opcode derived from yet another set, that developed for an earlier version of the same processor on which Smalltalk was first implemented. It copied an arbitrary sized block of bits from one location in memory to another location in memory, without having to do any tedious and time consuming messing about with incrementing counters (yes, of course counters were being incremented underneath, but they were in registers only accessible to the the microcode and which ran, I think, significantly faster than the 'main' registers). This highly optimised block transfer routine allowed a rich and responsive WIMP interface on a large bitmapped display on what weren't, underneath it all, actually terribly powerful machines.
-
-## BITBLT for the modern age
-
-Why is BITBLT interesting to us? Well, if we can transfer the contents of only one memory location over the bus in a message, and every message also needs a start-of-message marker and an object reference, then clearly the bus is going to run quite slowly. But if we can say, OK, here's an object which comprises this number of words, coming sequentially after this header, then the amount of overhead to queuing messages on the bus is significantly reduced. But, we need not limit ourselves to outputting as single messages on the bus, data which was contiguous in main memory.
-
-Most of the things which will be requested will be either vectors (yes, Java fans, an object is a vector) or lists. Vectors will normally point to other objects which will be needed at the same time as the vector itself is needed; list structures will almost always do so. Vectors will of course normally be contiguous in memory but the things they point to won't be contiguous with them; lists are from this point of view like structures of linked vectors such that each vector has only two cells.
-
-So we can envisage a bus transfer language which is in itself like a very simple lisp, except decorated with object references. So we might send the list '(1000 (2000) 3000) over the bus as notionally
-
-[ #00001 1000 [ #00002 2000 ] 3000 ]
-
-where '[' represents start-of-object, '#00001' is an object reference, '1000' is a numeric value, and ']' is end-of-object. How exactly is this represented on the bus? I'll come back to that; it isn't the main problem just now.
-
-## Requesting and listening
-
-Each processor can put requests onto the 'address bus'. Because the address bus is available to every processing node, every processing node can listen to it. And consequently every processing node does listen to it, noting every request that passes over the bus in a local request cache, and removing the note when it sees the response come back over the data bus.
-
-When a processing node wants a piece of data, it first checks its local memory to see whether it already has a copy. If it does, fine, it can immediately process it. If not, it checks to see whether the piece of data has already been requested. If it has not, it requests it. Then it waits for it to come up the bus, copies it off into local store and processes it.
-
-That all sounds rather elaborate, doesn't it? An extremely expensive way of accessing shared storage?
-
-Well, actually, no. I think it's not. Let's go back to where we began: to map.
-
-Mapping is a very fundamental computing operation; it's done all the time. Apply this same identical function to these closely related arguments, and return the results.
-
-So, first processor gets the map, and passes a reference to the function and arguments, together with indices indicating which arguments to work on, to each of its unemployed neighbours. One of the neighbours then makes a request for the function and the list of arguments. Each other processor sees the request has been made, so just waits for the results. While waiting, each in this second tier of processors may sub-partition its work block and farm out work to unemployed third tier neighbours, and so on. As the results come back up the bus, each processor takes its local copy and gets on with its partition, finally passing the results back to the neighbour who originally invoked it.
-
-## The memory manager
-
-All this implies that somewhere in the centre of this web, like a fat spider, there must be a single agent which is listening on the address bus for requests for memory objects, and fulfilling those requests by writing the objects out to the data bus. That agent is the memory manager; it could be software running on a dedicated processor, or it could be hardware. It really doesn't matter. It's operating a simple fundamental algorithm, maintaining a garbage collected heap of memory items and responding to requests. It shouldn't be running any 'userspace' code.
-
-Obviously, there has to be some way for processor nodes to signal to the memory manager that they want to store new persistent objects; there needs to be some way of propagating back which objects are still referenced from code which is in play, and which objects are no longer referenced and may be garbage collected. I know I haven't worked out all the details yet. Furthermore, of course, I know that I know virtually nothing about hardware, and have neither the money nor the skills to build this thing, so like my enormous game engine which I really know I'll never finish, it's really more an intellectual exercise than a project.
-
-But... I do think that somewhere in these ideas there are features which would enable us to build higher performance computers which we could actually program, with existing technology. I wouldn't be surprised to see systems fairly like what I'm describing here becoming commonplace within twenty years.
-
-\[Note to self: when I come to rework this essay it would be good to reference [Steele and Sussman, Design of LISP-based Processors](http://repository.readscheme.org/ftp/papers/ai-lab-pubs/AIM-514.pdf).\]
\ No newline at end of file
diff --git a/docs/Post-scarcity-software.md b/docs/Post-scarcity-software.md
deleted file mode 100644
index 07fcbf9..0000000
--- a/docs/Post-scarcity-software.md
+++ /dev/null
@@ -1,261 +0,0 @@
-# Post Scarcity Software
-
-_This is the text of my essay Post-scarcity Software, originally published in 2006 on my blog [here](https://www.journeyman.cc/blog/posts-output/2006-02-20-postscarcity-software/)._
-
-For years we've said that our computers were Turing equivalent, equivalent to Turing's machine U. That they could compute any function which could be computed. They aren't, of course, and they can't, for one very important reason. U had infinite store, and our machines don't. We have always been store-poor. We've been mill-poor, too: our processors have been slow, running at hundreds, then a few thousands, of cycles per second. We haven't been able to afford the cycles to do any sophisticated munging of our data. What we stored - in the most store intensive format we had - was what we got, and what we delivered to our users. It was a compromise, but a compromise forced on us by the inadequacy of our machines.
-
-The thing is, we've been programming for sixty years now. When I was learning my trade, I worked with a few people who'd worked on Baby - the Manchester Mark One - and even with two people who remembered Turing personally. They were old then, approaching retirement; great software people with great skills to pass on, the last of the first generation programmers. I'm a second generation programmer, and I'm fifty. Most people in software would reckon me too old now to cut code. The people cutting code in the front line now know the name Turing, of course, because they learned about U in their first year classes; but Turing as a person - as someone with a personality, quirks, foibles - is no more real to them than Christopher Columbus or Noah, and, indeed, much less real than Aragorn of the Dunedain.
-
-In the passing generations we've forgotten things. We've forgotten the compromises we've made; we've forgotten the reasons we've made them. We're no longer poor. The machine on which I'm typing this - my personal machine, on my desk, used by no-one but me - has the processor power of slightly over six thousand DEC VAXes; it has the one hundred and sixty two thousand times as much core store as the ICL 1900 mainframe on which I learned Pascal. Yet both the VAX and the 1900 were powerful machines, capable of supporting dozens of users at the same time. Compared to each individual user of the VAX, of the 1900, I am now incalculably rich. Vastly. Incomprehensibly.
-
-And it's not just me. With the exception of those poor souls writing embedded code for micro-controllers, every programmer now working has processor and store available to him which the designers of the languages and operating systems we still use could not even have dreamed of. UNIX was designed when 32 bit machines were new, when 16,384 bytes was a lot of memory and very expensive. VMS - what we now call 'Windows XP' - is only a few years younger.
-
-The compromises of poverty are built into these operating systems, into our programming languages, into our brains as programmers; so deeply ingrained that we've forgotten that they are compromises, we've forgotten why we chose them. Like misers counting grains on the granary floor while outside the new crop is falling from the stalks for want of harvesting, we sit in the middle of great riches and behave as though we were destitute.
-
-One of the things which has made this worse in recent years is the rise of Java, and, following slavishly after it, C#. Java is a language which was designed to write programs for precisely those embedded micro-controllers which are still both store and mill poor. It is a language in which the mind-set of poverty is consciously ingrained. And yet we have adopted it as a general purpose programming language, something for which it is not at all suitable, and in doing so have taught another generation of programmers the mind-set of poverty. Java was at least designed; decisions were made for reasons, and, from the point of view of embedded micro-controllers, those reasons were good. C# is just a fit of pique as software. Not able to 'embrace and extend' Java, Microsoft aped it as closely as was possible without breaching Sun's copyright. Every mistake, every compromise to poverty ingrained in Java is there in C# for all the world to see.
-
-It's time to stop this. Of course we're not as wealthy as Turing. Of course our machines still do not have infinite store. But we now have so much store - and so many processor cycles - that we should stop treating them as finite. We should program as if we were programming for U.
-
-# Store, Name and Value
-
-So let's start with what we store, what we compute on: values. For any given column within a table, for every given instance variable in a class, every record, every object is constrained to have a value with a certain format.
-
-This is, of course, historical. Historically, when storage was expensive we stored textual values in fields of fixed width to economise on storage; we still do so largely because that's what we've always done rather than because there's any longer any rational reason to. Historically, when storage and computation were expensive, we stored numbers in twos-complement binary strings in a fixed number of bytes. That's efficient, both of store and of mill.
-
-But it is no longer necessary, nor is it desirable, and good computer languages such as LISP transparently ignores the difference between the storage format of different numbers. For example:
-
- (defun factorial (n)
- (cond
- ((eq n 1) 1)
- (t (* n (factorial (- n 1))))))
-
- ;; a quick way to generate very big numbers...
-
-We can add the value of factorial 100 to an integer, say 2, in just the same way that we can add any other two numbers:
-
- (+ (fact 100) 2)
- 933262154439441526816992388562667004907159682643816214685929638952175999932299156089414639761565182862536979208272237582511852109168 64000000000000000000000002
-
-We can multiply the value of factorial 100 by a real number, say pi, in just the same way as we can add any other two numbers:
-
- (* (factorial 100) pi)
- 2.931929528260332*10^158
-
-The important point to note here is that there's no explicit call to a bignum library or any other special coding. LISP's arithmetic operators don't care what the underlying storage format of a number is, or rather, are able transparently to handle any of the number storage formats - including bignums - known to the system. There's nothing new about this. LISP has been doing this since the late 1960s. Which is as it should be, and, indeed, as it should be in storage as well as in computation.
-
-A variable or a database field (I'll treat the two as interchangeable, because, as you will see, they are) may reasonably have a validation rule which says that a value which represents the longitude of a point on the Earth in degrees should not contain a value which is greater than 360. That validation rule is domain knowledge, which is a good thing; it allows the system to have some vestige of common sense. The system can then throw an exception when it is asked to store 764 as the longitude of a point, and this is a good thing.
-
-Why then should a database not throw an exception when, for example, a number is too big to fit in the internal representation of a field? To answer, here's a story I heard recently, which seems to be apocryphal, but which neatly illustrates the issue just the same.
-
-_The US Internal Revenue Service have to use a non-Microsoft computer to process Bill Gate's income tax, because Microsoft computers have too small an integer representation to represent his annual income._
-
-Twos complement binary integers stored in 32 bits can represent plus or minus 2,147,483,648, slightly over two US billion. So it's easily possible that Bill Gates' income exceeds this. Until recently, Microsoft operating systems ran only on computers with a register size of 32 bits. Worryingly, the default integer size of my favourite database, Postgres, is also 32 bits.
-
-This is just wrong. Nothing in the domain of income places any fixed upper bound on the income a person may receive. Indeed, with inflation, the upper limit on incomes as quantity is likely to continue to rise. Should we patch the present problem by upping the size of the integer to eight bytes?
-
-In Hungary after the end of World War II inflation ran at 4.19 * 10^16 percent per month - prices doubled every 15 hours. Suppose Gates' income in US dollars currently exceeds the size of a thirty two bit integer, it would take at most 465 hours - less than twenty days - to exceed US$9,223,372,036,854,775,808. What's scary is how quickly you'd follow him. If your present annual salary is just thirty three thousand of your local currency units, then given that rate of inflation, you would overflow a sixty-four bit integer in just 720 hours, or less than a month.
-
-Lots of things in perfectly ordinary domains are essentially unbounded. They aren't shorts. They aren't longs. They aren't doubles. They're numbers. And a system asked to store a number should store a number. Failure to store a number because it's size violates some constraint derived from domain knowledge is desirable behaviour; failure to store a number because it size violates the internal storage representation of the system is just bad, outdated, obsolete system design. Yes, it's efficient of compute power on thirty-two bit processors to store values in thirty-two bit representations. Equally, it's efficient of disk space for a database to know in advance just how mush disk it has to reserve for each record in a table, so that to skip to the Nth record it merely has to skip forward (N * record-size) bytes.
-
-But we're no longer short of either processor cycles or disk space. For a database to reject a value because it cannot be stored in a particular internal representation is industrial archaeology. It is a primitive and antiquated workaround from days of hardware scarcity. In these days of post-scarcity computing, it's something we should long have forgotten, long have cast aside.
-
-This isn't to say that integers should never be stored in thirty-two bit twos complement binary strings. Of course they should, when it's convenient to do so. It's a very efficient storage representation. Of course, when a number overflows a thirty two bit cell, the runtime system has got to throw an exception, has got to deal with it, and consequently the programmer who writes the runtime system has still got to know about and understand the murky aspects of internal storage formats.
-
-Perhaps the language designer, and the programmer who writes the language compiler should, too, but personally I don't think so. I think that at the layer in the system - the level of abstraction - at which the compiler writer works, the operator 'plus' should just be a primitive. It takes two numbers, and returns a number. That's all. The details of whether that's a float, a double, a rational or a bignum should not be in the least relevant at the level of language. There is a difference which is important between a real number and an integer. The old statistical joke about the average family having 2.4 children is funny precisely because it violates our domain knowledge. No family has 2.4 children. Some things, including children, are discrete, however indiscreet you may think them. They come in integral quantities. But they don't come in short quantities or long quantities. Shorts and longs, floats and doubles are artefacts of scarcity of store. They're obsolete.
-
-From the point of view of the runtime designer, the difference between a quantity that can be stored in two bytes, or four, or eight must matter. From the point of view of the application designer, the language designer, even the operating system designer, they should disappear. An integer should be an integer, whether it represents the number of toes on your left foot (about 5), the number of stars in the galaxy (about 1x1011) or the number of atoms in the universe (about 1x1079). Similarly, a real number should be just a real number.
-
-This isn't to say we can't do data validation. It isn't to say we can't throw a soft exception - or even a hard one - when a value stored in a variable or field violates some expectation, which may be an expectation about size. But that should be an expectation based on domain knowledge, and domain knowledge alone; it should not be an expectation based on implementation knowledge.
-
-Having ranted now for some time about numbers, do you think I'm finished? I'm not. We store character values in databases in fields of fixed size. How big a field do we allocate for someone's name? Twenty four characters? Thirty-two? We've all done it. And then we've all found a person who violates our previous expectation of the size of a name, and next time we've made the field a little bigger. But by the time we've made a field big enough to store Charles Philip Arthur George Windsor or Sirimavo Ratwatte Dias Bandaranaike we've negated the point of fixed width fields in the first place, which was economy. There is no natural upper bound to the length of a personal name. There is no natural upper bound to the length of a street address. Almost all character data is a representation at some level of things people say, and the human mind doesn't work like that.
-
-Of course, over the past fifty years, we've tried to make the human mind work like that. We've given addresses standardised 'zip codes' and 'postcodes', we've given people standardised 'social security numbers' and 'identity codes'. We've tried to fit natural things into fixed width fields; we've tried to back-port the inadequacies of our technology onto the world. It's stupid, and it's time we stopped.
-
-So how long is a piece of string? How long is a string of characters? It's unbounded. Most names are short, because short names are convenient and memorable. But that does not mean that for any given number of characters, it's impossible that there should be something with a normal name of that length. And names are not the only things we store in character strings. In character strings we store things people say, and people talk a lot.
-
-At this point the C programmers, the Java programmers are looking smug. Our strings, they say, are unbounded. Sorry lads. A C string is a null terminated sequence of bytes. It can in principle be any length. Except that it lives in a malloced lump of heap (how quaint, manually allocating store) and the maximum size of a lump of heap you can malloc is size_t, which may be 231, 232, 263 or 264 depending on the system. Minus one, of course, for the null byte. In Java, similarly, the size of a String is an int, and an int, in Java, means 231.
-
-Interestingly, Paul Graham, in his essay 'The Hundred YearLanguage', suggests doing away with stings altogether, and representing them as lists of characters. This is powerful because strings become S-expressions and can be handled as S-expressions; but strings are inherently one-dimensional and S-expressions are not. So unless you have some definite collating sequence for a branching 'string' it's meaning may be ambiguous. Nevertheless, in principle and depending on the internal representation of a CONS cell, a list of characters can be of indefinite extent, and, while it isn't efficient of storage, it is efficient of allocation and deallocation; to store a list of N characters does not require us to have a contiguous lump of N bytes available on the heap; nor does it require us to shuffle the heap to make a contiguous lump of that size available.
-
-So; to reprise, briefly.
-
-A value is just a value. The internal representation of a value is uninteresting, except to the designer and author of the runtime system - the virtual machine. For programmers at every other level the internal representation of every value is DKDC: don't know, don't care. This is just as true of things which are fundamentally things people say, things which are lists and things which are pools, as it is of numbers. The representation that the user - including the programmer - deals with is the representation which is convenient and comfortable. It does not necessarily have anything to do with the storage representation; the storage representation is something the runtime system deals with, and that the runtime system effectively hides. Operators exposed by the virtual machine are operators on values. It is a fundamental error, a failure of the runtime designer's most basic skill and craft, for a program ever to fail because a value could not be represented in internal representation - unless the store available to the system is utterly exhausted.
-
-# Excalibur and the Pool
-
-A variable is a handle in a namespace; it gives a name to a value, so that we can recall it. Storing a value in a variable never causes an exception to be thrown because the value cannot be stored. But it may, reasonably, justifiably, throw an exception because the value violates domain expectations. Furthermore, this exception can be either soft or hard. We might throw a soft exception if someone stored, in a variable representing the age of a person in years, the value 122. We don't expect people to reach one hundred and twenty two years of age. It's reasonable to flag back to whatever tried to set this value that it is out of the expected range. But we should store it, because it's not impossible. If, however, someone tries to store 372 in a variable representing longitude in degrees, we should throw a hard exception and not store it, because that violates not merely a domain expectation but a domain rule.
-
-So a variable is more than just a name. It is a slot: a name with some optional knowledge about what may reasonably be associated with itself. It has some sort of setter method, and possibly a getter method as well.
-
-I've talked about variables, about names and values. Now I'll talk about the most powerful abstraction I use - possibly the most powerful abstraction in software - the namespace. A namespace is a sort of pool into which we can throw arbitrary things, tagging each with a distinct name. When we return to the pool and invoke a name, the thing in the pool to which we gave that name appears.
-
-## Regularities: tables, classes, patterns
-
-Database tables, considered as sets of namespaces, have a special property: they are regular. Every namespace which is a record in the same table has the same names. A class in a conventional object oriented language is similar: each object in the class has the same set of named instance variables. They match a pattern: they are in fact constrained to match it, simply by being created in that table or class.
-
-Records in a table, and instance variables in a class, also have another property in common. For any given name of a field or instance variable, the value which each record or object will store under that name is of the same type. If 'Age' is an integer in the definition of the table or class, the Age of every member will be an integer. This property is different from regularity, and, lacking a better word for it, I'll call it homogeneity. A set of spaces which are regular (i.e. share the same names) need not be homogeneous (i.e. share the same value types for those names), but a set which is homogeneous must be regular.
-
-But records in a table, in a view, in a result set are normally in themselves values whose names are the values of the key field. And the tables and views, too, are values in a namespace whose names are the table names, and so on up. Namespaces, like Russian dolls, can be nested indefinitely. By applying names to the nested spaces at each level, we can form a path of names to every space in the meta-space and to each value in each space, provided that the meta-space forms an acyclic directed graph (this is, after all, the basis of the XPath language. Indeed, we can form paths even if the graph has cycles, provided every cycle in the graph has some link back to the root.
-
-## Social mobility
-
-It's pretty useful to gather together all objects in the data space which match the same pattern; it's pretty useful for them all to have distinct names. So the general concept of a regularity which is itself a namespace is a useful one, even if the names have to be gensymed.
-
-To be in a class (or table), must a space be created in that class (or table)? I don't see why. One of my earlier projects was an inference engine called Wildwood, in which objects inferred their own class by exploring the taxonomy of classes until they found the one in which they felt most comfortable. I think this is a good model. You ought to be able to give your dataspace a good shake and then pull out of it as a collection all the objects which match any given pattern, and this collection ought to be a namespace. It ought to be so even if the pattern did not previously exist in the data space as the definition of a table or class or regularity or whatever you care to call it.
-
-A consequence of this concept is that objects which acquire new name-value pairs may move out of the regularity in which they were created either to exist as stateless persons in the no-man's land of the dataspace, or into a new regularity; or may form the seed around which a new regularity can grow. An object which acquires a value for one of its names which violates the validation constraints of one homogeneity may similarly move out into no-man's land or into another. In some domains, in some regularities, it may be a hard error to do this (i.e. the system will prevent it). In some domains, in some regularities, it may be a soft error (i.e. the system allows it under protest). In some domains, in some regularities, it may be normal; social mobility of objects will be allowed.
-
-## Permeability
-
-There's another feature of namespaces which gets hard wired into lots of software structures without very often being generalised, and that is permeability, semi-translucency. In my toolkit Jacquard, for example, values are first searched for in the namespace of http parameters; if not found there, in the namespace of cookies; next, in the namespace of session variables, then in local configuration parameters, finally in global configuration parameters. There is in effect a layering of semi-translucent namespaces like the veils of a dancer.
-
-It's not a pattern that's novel or unique to Jacquard, of course. But in Jacquard it's hard wired and in all the other contexts in which I've seen this pattern it's hardwired. I'd like to be able to manipulate the veils; to add, or remove, of alter the layering. I'd like this to be a normal thing to be able to do.
-The Name of the Rose: normativeness and hegemony
-I have a friend called Big Nasty. Not everyone, of course, calls him Big Nasty. His sons call him 'Dad'. His wife calls him 'Norman'. People who don't know him very well call him 'Mr Maxwell'. He does not have one true name.
-
-The concept of a true name is a seductive one. In many of the traditions of magic - and I have always seen software as a technological descendant or even a technological implementation of magic - a being invoked by its true name must obey. In most modern programming languages, things tend to have true names. There is a protocol for naming Java packages which is intended to guarantee that every package written anywhere in the world has a globally unique true name. Globally unique true names do then have utility. It's often important when invoking something to be certain you know exactly what it is you're invoking.
-
-But it does not seem to me that this hegemonistic view of the dataspace is required by my messy conception. Certainly it cannot be true that an object has only one true name, since it may be the value of several names within several spaces (and of course this is true of Java; a class well may have One True Name, but I can still create an instance variable within an object whose name is anythingILike, and have its value is that class).
-
-The dataspace I conceive is a soup. The relationships between regularities are not fixed, and so paths will inevitably shift. And in the dataspace, one sword can be in many pools - or even many times in the same pool, under different names - at the same time. We can shake the dataspace in different ways to see different views on the data. There should be no One True hegemonistic view.
-
-This does raise the question, 'what is a name'. In many modern relational databases, all primary keys are abstract and are numbers, even if natural primary keys exist in the data - simply because it is so easy to create a table with an auto-incrementer on the key field. Easy, quick, convenient, lazy, not always a good thing. In terms of implementation details, namespaces are implemented on top of hash tables, and any data object can be hashed. So can anything be a name?
-
-In principle yes. However, my preference would be to purely arbitrarily say no. My preference would be to say that a name must be a 'thing people say', a pronounceable sequence of characters; and also, with no specific upper bound, reasonably short.
-
-## The Problem with Syntax
-
-Let me start by saying that I really don't understand the problem with syntax. Programming language designers spend a lot of time worrying about it, but I believe they're simply missing the point. People say 'I can't learn LISP because I couldn't cope with all the brackets'. People - the Dylan team, for one - have developed systems which put a skin of 'normal' (i.e., ALGOL-like) syntax on top of LISP. I personally won't learn Python because I don't trust a language where white space is significant. But in admitting that prejudice I'm admitting to a mistake which most software people make.
-
-We treat code as if it wasn't data. We treat code as if it were different, special. This is the mistake made by the LISP2 brigade, when they gave their LISPs (ultimately including Common LISP) separate namespaces, one for 'code' and one for 'data'. It's a fundamental mistake, a mistake which fundamentally limits our ability to even think about software.
-
-What do I mean by this?
-
-Suppose I ask my computer to store pi, 3.14159265358979. Do I imagine that somewhere deep within the machine there is a bitmap representation of the characters? No, of course I don't. Do I imagine there's a vector starting with the bytes 50 46 49 51 49 53 57 ...? Well, of course, there might be, but I hope there isn't because it would be horribly inefficient. No, I hope and expect there's an IEEE 754 binary encoding of the form 01100100100001111...10. But actually, frankly, I don't know, and I don't care, provided that it is stored and that it can be computed with.
-
-However, as to what happens if I then ask my computer to show me the value it has stored, I do know and I do care. I expect it to show me the character string '3.14159265358979' (although I will accept a small amount of rounding error, and I might want it to be truncated to a certain number of significant figures). The point is, I expect the computer to reflect the value I have stored back to me in a form which it is convenient for me to read, and, of course, it can.
-
-We don't, however, expect the computer to be able to reflect back an executable for us in a convenient form, and that is in itself a curious thing. If we load, for example, the UNIX command 'ls' into a text editor, we don't see the source code. We see instead, the raw internal format. And the amazing thing is that we tolerate this.
-
-It isn't even that hard to write a 'decompiler' which can take a binary and reflect back source code in a usable form. Here, for example, is a method I wrote:
-
- /**
- * Return my action: a method, to allow for specialisation. Note: this
- * method was formerly 'getAction()'; it has been renamed to disambiguate
- * it from 'action' in the sense of ActionWidgets, etc.
- */
- public String getNextActionURL( Context context ) throws Exception
- {
- String nextaction = null;
-
- HttpServletRequest request =
- (HttpServletRequest) context.get( REQUESTMAGICTOKEN );
-
- if ( request != null )
- {
- StringBuffer myURL = request.getRequestURL( );
-
- if ( action == null )
- {
- nextaction = myURL.toString( );
-
- // If I have no action, default my action
- // to recall myself
- }
- else
- {
- nextaction =
- new URL( new URL( myURL.toString( ) ), action ).toString( );
-
- // convert my action into a fully
- // qualified URL in the context of my
- // own
- }
- }
- else
- { // should not happen!
- throw new ServletException( "No request?" );
- }
-
- return nextaction;
- }
-
-and here is the result of 'decompiling' that method with an open-source Java decompiler, jreversepro:
-
- public String getNextActionURL(Context context)
- throws Exception
- {
- Object object = null;
- HttpServletRequest httpservletrequest =
- (HttpServletRequest)context.get( "servlet_request");
- String string;
- if (httpservletrequest != null) {
- StringBuffer stringbuffer = httpservletrequest.getRequestURL();
- if (action == null)
- string = stringbuffer.toString();
- else
- string = new URL(new URL(stringbuffer.toString()) ,
- action).toString();
- }
- else
- throw new ServletException("No request?");
-
- return (string);
- }
-
-As you can see, the comments have been lost and some variable names have changed, but the code is essentially the same and is perfectly readable. And this is with an internal form which has not been designed with decompilation in mind. If decompilation had been designed for in the first place, the binary could have contained pointers to the variable names and comments. Historically we haven't done this, both for 'intellectual property' reasons and because of store poverty. In future, we can and will.
-
-Again, like so much in software, this isn't actually new. The microcomputer BASICs of the seventies and eighties 'tokenised' the source input by the user. This tokenisation was not of course compilation, but it was analogous to it. The internal form of the program that was stored was much terser then the representation the user typed. But when the user asked to list the program, it was expanded into its original form.
-
-Compilation - even compilation into the language of a virtual machine - is much more sophisticated than tokenising, of course. Optimisation means that many source constructs may map onto one object construct, and even that one source construct may in different circumstances map onto many object constructs. Nevertheless it is not impossible - nor even hugely difficult - to decompile object code back into readable, understandable and editable source.
-
-But Java syntax is merely a format. When I type a date into a computer, say '05-02-2005', and ask it to reflect that date back to me, I expect it to be able to reflect back to me '05-02-2006'. But I expect it to be able to reflect back to an American '02-05-2006', and to either of us 'Sunday 5th February 2006' as well. I don't expect the input format to dictate the output format. I expect the output format to reflect the needs and expectations of the person to whom it is displayed.
-
-To summarise, again.
-
-Code is data. The internal representation of data is Don't Know, Don't Care. The output format of data is not constrained by the input format; it should suit the use to which it is to be put, the person to whom it is to be displayed.
-
-Thus if the person to whom my Java code is reflected back is a LISP programmer, it should be reflected back in idiomatic LISP syntax; if a Python programmer, in idiomatic Python syntax. Let us not, for goodness sake, get hung up about syntax; syntax is frosting on the top. What's important is that the programmer editing the code should edit something which is clearly understandable to him or her.
-
-This has, of course, a corollary. In InterLISP, one didn't edit files 'out of core' with a text editor. One edited the source code of functions as S-expressions, in core, with a structure editor. The canonical form of the function was therefore the S-expression structure, and not the printed representation of it. If a piece of code - a piece of executable binary, or rather, of executable DKDC - can be reflected back to users with a variety of different syntactic frostings, none of these can be canonical. The canonical form of the code, which must be stored in version control systems or their equivalent, is the DKDC itself; and to that extent we do care and do need to know, at least to the extent that we need to know that the surface frosting can again be applied systematically to the recovered content of the archive.
-
-# If God does not write LISP
-
-I started my professional life writing LISP on Xerox 1108s and, later, 1186s - Dandelions and Daybreaks, if you prefer names to numbers. When I wanted to multiply two numbers, I multiplied two numbers. I didn't make sure that the result wouldn't overflow some arbitrary store size first. When a function I wrote broke, I edited in its structure in its position on the stack, and continued the computation. I didn't abort the computation, find a source file (source file? How crude and primitive), load it into a text editor, edit the text, save it, check for syntax errors, compile it, load the new binary, and restart the computation. That was more than twenty years ago. It is truly remarkable how software development environments have failed to advance - have actually gone backwards - in that time.
-
-LISP's problem is that it dared to try to behave as though it were a post-scarcity language too soon. The big LISP machines - not just the Xerox machines, the LMI, Symbolics, Ti Explorer machines - were vastly too expensive. My Daybreak had 8Mb of core and 80Mb of disk when PCs usually didn't even have the full 640Kb. They were out-competed by UNIX boxes from Sun and Apollo, which delivered less good software development environments but at a much lower cost. They paid the price for coming too early: they died. And programmers have been paying the price for their failure ever since.
-
-But you only have to look at a fern moss, a frond of bracken, an elm sapling, the water curling over the lip of a waterfall, to know that if God does not write LISP She writes some language so similar to LISP as to make no difference. DNA encodes recursive functions; turbulent fluids move in patterns formed by recursion, whorls within whorls within whorls.
-
-The internal structure, then, of the post scarcity language is rather lisp-like. Don't get hung up on that! Remember that syntax isn't language, that the syntax you see need not be the syntax I see. What I mean by saying the language is lisp-like is that its fundamental operation is recursion, that things can easily be arranged into arbitrary structures, that new types of structure can be created on the fly, that new code (code is just data, after all) can be created and executed on the fly, that there is no primacy of the structures and the code created by the programmer over the structures and code created by the running system; that new code can be loaded and linked seamlessly into a running system at any time. That instead of little discrete programs doing little discrete specialised things in separate data spaces each with its own special internal format and internal structures, the whole data space of all the data available to the machine (including, of course, all the code owned by the machine) exists in a single, complex, messy, powerful pool. That a process doesn't have to make a special arrangement, use a special protocol, to talk to another process or to exchange data with it.
-
-In that pool, the internal storage representation of data objects is DKDC. We neither have nor need to have access to it. It may well change over time without application layer programs even being aware or needing to be aware of the change, certainly without them being recompiled.
-
-The things we can store in the dataspace include:
-
-1. **integers** of any size
-1. **reals** to any appropriate degree of precision
-1. **rationals, complex numbers**, and other things we might want to compute with
-1. **dates, times**, and other such useful things
-1. **things people say** of any extent, from names to novels
-1. **lists of any extent**, branching or not
-1. **slots** associations of names with some setter and, perhaps, getter knowledge which determine what values can be stored under that name
-1. **namespaces** collections, extensible or not, of slots
-1. **regularities** collections of namespaces each of which share identical names
-1. **homogeneities** collections of namespaces each of which share identical slots
-1. **functions** all executable things are 'functions' in a lispy sense. They are applied to arguments and return values. They may or may not have internal expectations as to the value type of those arguments.
-1. **processes** I don't yet have a good feeling for what a post-scarcity process looks like, at top level. It may simply be a thread executing a function; I don't know. I don't know whether there needs to be one specially privileged executive process.
-
-Things which we no longer store - which we no longer store because they no longer have any utility - include
-
-1. **shorts, longs, doubles**, etc specific internal representation types. You saw that coming.
-1. **tables**, and with them, **relational databases** and **relational database management systems** no longer needed because the pool is itself persistent (although achieving the efficiency of data access that mature RDBMS give us may be a challenge).
-1. **files** You didn't see that coming?
-
-Files are the most stupid, arbitrary way to store data. Again, with a persistent data pool, they cease to have any purpose. Post scarcity, there are no files and there is no filesystem. There's no distinction between in core and out of core. Or rather, if there are files and a filesystem, if there is a distinction between in core and out of core, that distinction falls under the doctrine of DKDC: we don't know about it, and we don't care about it. When something in the pool wants to use or refer to another something, then that other something is available in the pool. Whether it was there all along, or whether it was suddenly brought in from somewhere outside by the runtime system, we neither know nor care. If things in the pool which haven't been looked at for a long time are sent to sulk elsewhere by the runtime system that is equally uninteresting. Things which are not referenced at all, of course, may be quietly dropped by the runtime system in the course of normal garbage collection.
-
-One of the things we've overloaded onto the filesystem is security. In core, in modern systems, each process guards its own pool of store jealously, allowing other processes to share data with it only through special channels and protocols, even if the two processes are run by the same user identity with the same privilege. That's ridiculous. Out of core, data is stored in files often with inscrutable internal format, each with its own permissions and access control list.
-
-It doesn't need to be that way. Each primitive data item in core - each integer, each list node, each slot, each namespace - can have its own access control mechanism. Processes, as such, will never 'own' data items, and will certainly never 'own' chunks of store - at the application layer, even the concept of a chunk of store will be invisible. A process can share a data item it has just created simply by setting an appropriate access policy on it, and programmers will be encouraged normally to be as liberal in this sharing as security allows. So the slot Salary of the namespace Simon might be visible only to the user Simon and the role Payroll, but that wouldn't stop anyone else looking at the slot Phone number of the same namespace.
-
-Welcome, then, to post scarcity computing. It may not look much like what you're used to, but if it doesn't it's because you've grown up with scarcity, and even since we left scarcity behind you've been living with software designed by people who grew up with scarcity, who still hoard when there's no need, who don't understand how to use wealth. It's a richer world, a world without arbitrary restrictions. If it looks a lot like Alan Kay (and friends)'s Croquet, that's because Alan Kay has been going down the right path for a long time.
\ No newline at end of file
diff --git a/docs/Regularity.md b/docs/Regularity.md
deleted file mode 100644
index 0b6d400..0000000
--- a/docs/Regularity.md
+++ /dev/null
@@ -1,20 +0,0 @@
-# Regularity
-
-A regularity is a map whose values are maps, all of whose members share the same keys. A map may be added to a regularity only if it has all the keys the regularity expects, although it may optionally have more. It is legitimate for the same map to be a member of two different regularities, if it has a union of their keys. Keys in a regularity must be keywords. Regularities are roughly the same sort of thing as classes in object oriented programming or tables in databases, but the values of the keys are not policed (see homogeneity).
-
-A regularity may also have an association of methods, that is, functions which accept a member of the regularity as their first argument; this set of methods forms an API to the regularity. Of course a full hierarchical object oriented model can be layered on top of this, but a regularity does not in itself have any concept of class inheritance.
-
-But, for example, if we have a regularity whose members represent companies, and those companies each have employees, then there might be a method :payroll of companies which might internally look like:
-
-(lambda (company)
- (reduce + (map do-something-to-get-salary (:employees company))))
-
-which would be accessed
-
-(with ((companies . ::shared:pool:companies)
- (acme . companies:acme-widgets))
- (companies:methods:payroll acme))
-
-But salary is not a property of a company, it's a property of an employee; so what is this thing called do-something-to-get-salary? It's a method on the regularity of employees, so in this example, it is ::shared:pool:employees:methods:salary.
-
-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.
\ No newline at end of file
diff --git a/docs/Roadmap.md b/docs/Roadmap.md
deleted file mode 100644
index 7cd654b..0000000
--- a/docs/Roadmap.md
+++ /dev/null
@@ -1,58 +0,0 @@
-# Roadmap
-
-With the release of 0.0.6 close, it's time to look at a plan for the future development of the project.
-
-I have an almost-working Lisp interpreter, which, as an interpreter, has many of the features of the language I want. It runs in one thread on one processor.
-
-Given how experimental this all is, I don't think I need it to be a polished interpreter, and polished it isn't. Lots of things are broken.
-
-* garbage collection is pretty broken, and I'n beginning to doubt my whole garbage collection strategy;
-* bignums are horribly broken;
-* there's something very broken in shallow-bound symbols, and that matters and wil have to be fixed;
-* there are undoubtedly many other bugs I don't know about.
-
-However, while I will fix bugs where I can, it's good enough for other people to play with if they're mad enough, and it's time to move on.
-
-## Next major milestones
-
-### Simulated hypercube
-
-There is really no point to this whole project while it remains a single thread running on a single processor. Until I can pass off computation to peer neighbours, I can't begin to understand what the right strategies are for when to do so.
-
-`cond` is explicitly sequential, since later clauses should not be executed at all if earlier ones succeed. `progn` is sort of implicitly sequential, since it's the value of the last form in the sequence which will be returned.
-
-For `mapcar`, the right strategy might be to partition the list argument between each of the idle neighbours, and then reassemble the results that come bask.
-
-For most other things, my hunch is that you pass args which are not self-evaluating to idle neighbours, keeping (at least) one on the originating node to work on while they're busy.
-
-But before that can happen, we need a router on each node which can monitor concurrent traffic on six bidirectional links. I think at least initially what gets written across those links is just S-expressions.
-
-I think a working simulated hypercube is the key milestone for version 0.0.7.
-
-### Sysout, sysin, and system persistance
-
-Doctrine is that the post scarcity computing environment doesn't have a file system, but nevertheless we need some way of making an image of a working system so that, after a catastrophic crash or a power outage, it can be brought back up to a known good state. This also really needs to be in 0.0.7.
-
-### Better command line experience
-
-The current command line experience is embarrassingly poor. Recallable input history, input line editing, and a proper structure editor are all things that I will need for my comfort.
-
-### Users, groups and ACLs
-
-Allowing multiple users to work together within the same post scarcity computing environment while retaining security and privacy is a major goal. So working out ways for users to sign on and be authenticated, and to configure their own environment, and to set up their own access control lists on objects they create, needs to be another nearish term goal. Probably 0.0.8.
-
-### Homogeneities, regularities, slots, migration, permeability
-
-There are a lot of good ideas about the categorisation and organisation of data which are sketched in my original [Post scarcity software](Post-scarcity-software.md) essay which I've never really developed further because I didn't have the right software environment for them, which now I shall have. It would be good to build them.
-
-### Compiler
-
-I do want this system to have a compiler. I do want compiled functions to be the default. And I do want to understand how to write my own compiler for a system like this. But until I know what the processor architecture of the system I'm targetting is, worrying too much about a compiler seems premature.
-
-### Graphical User Interface
-
-Ultimately I want a graphical user interface at least as fluid and flexible as what we had on Interlisp machines 40 years ago. It's not a near term goal there.
-
-### Real hardware
-
-This machine would be **very** expensive to build, and there's no way I'm ever going to afford more than a sixty-four node machine. But it would be nice to have software which would run effectively on a four billion node machine, if one could ever be built. I think that has to be the target for version 1.0.0.
\ No newline at end of file
diff --git a/docs/Stack.md b/docs/Stack.md
deleted file mode 100644
index 04ebe72..0000000
--- a/docs/Stack.md
+++ /dev/null
@@ -1,40 +0,0 @@
-# Stack
-
-The C (and I assume but don't know) Rust stack are contiguous blocks of memory which grow down from the top of the virtual memory map allocated by the operating system to the process. The Lisp stack doesn't have to be the same as the C stack and in fact probably cannot be if I want to have multiple Lisp threads running concurrently in the same process.
-
-If the Lisp stack and the implementation language stack are different, then it's more awkward for Lisp to call functions written in the implementation language and vice versa, but not impossible.
-
-Past Lisps have implemented stack as lists and as vectors. Both work. My own guess is that it possibly best to have a standard sized stack frame allocated in vector space, so that each frame is a contiguous block of memory. A stack frame needs to contain parameters, a return pointer, and somewhere the caller will pick up the return value from. I think a stack frame should have the following:
-
- +-----------------+-----------------+---------------------------------------------------+
- | tag | 0...31 | 'STCK' |
- +-----------------+-----------------+---------------------------------------------------+
- | vecp-pointer | 32...95 | cons-pointer to my VECP (or NIL?) |
- +-----------------+-----------------+---------------------------------------------------+
- | size | 96...159 | 77 |
- +-----------------+-----------------+---------------------------------------------------+
- | tag | 160...167 | 0 |
- +-----------------+-----------------+---------------------------------------------------+
- | parameter 1 | 168...231 | cons-pointer to first param |
- +-----------------+-----------------+---------------------------------------------------+
- | parameter 2 | 232...295 | cons-pointer to second param |
- +-----------------+-----------------+---------------------------------------------------+
- | parameter 3 | 296...359 | cons-pointer to third param |
- +-----------------+-----------------+---------------------------------------------------+
- | more params | 360...423 | cons-pointer to list of further params |
- +-----------------+-----------------+---------------------------------------------------+
- | return pointer | 424...487 | memory address of the instruction to return to |
- +-----------------+-----------------+---------------------------------------------------+
- | return value | 488...551 | cons pointer to return value |
- +-----------------+-----------------+---------------------------------------------------+
- | prior frame ptr | 552...615 | cons-pointer to preceding stack frame VECP |
- +-----------------+-----------------+---------------------------------------------------+
-
-Note that every argument to a Lisp function must be a [cons space object](Cons-space.html) passed by reference (i.e., a cons pointer). If the actual argument is actually a [vector space](Vector-space.html) object, then what we pass is a reference to the VECP object which references that vector.
-
-I'm not certain we need a prior frame pointer; if we don't, we may not need a VECP pointing to a stack frame, since nothing can point to a stack frame other than the next stack frame(s) up the stack (if we parallelise *map*, *and* and so on) which to implement a multi-thread system we essentially must have, there may be two or more successor frames to any frame. In fact to use a massively multiprocessor machine efficiently we must normally evaluate each parameter in a separate thread, with only special forms such as *cond* which impose explicit control flow evaluating their clauses serially in a single thread.
-
-*Uhhhmmm... to be able to inspect a stack frame, we will need a pointer to the stack frame. Whether that pointer should be constructed when the stack frame is constructed I don't know. It would be overhead for something which would infrequently be used.*
-
-However, modern systems with small numbers of processors and expensive thread construction and tear-down would perform **terribly** if all parameter evaluation was parallelised, so for now we can't do that, even though the semantics must be such that later we can.
-
\ No newline at end of file
diff --git a/docs/State-of-play.md b/docs/State-of-play.md
deleted file mode 100644
index c619b55..0000000
--- a/docs/State-of-play.md
+++ /dev/null
@@ -1,612 +0,0 @@
-# State of Play
-
-## 20260314
-
-When I put a debugger on it, the stack limit bug proved shallow.
-
-I'm tempted to further exercise my debugging skills by having another go at
-the bignum arithmetic problems.
-
-However, I've been rethinking the roadmap of the project, and written a long
-[blog post about it](https://www.journeyman.cc/blog/posts-output/2026-03-13-The-worlds-slowest-ever-rapid-prototype/).
-This isn't a finalised decision yet, but it is something I'm thinking about.
-
-## 20260311
-
-I've still been having trouble with runaway recursion — in `member`, but
-due to a primitive bug I haven't identified — so this morning I've tried
-to implement a stack limit feature. This has been a real fail at this stage.
-Many more tests are breaking.
-
-However, I think having a configurable stack limit would be a good thing, so
-I'm not yet ready to abandon this feature. I need to work out why it's breaking
-things.
-
-## 20260226
-
-The bug in `member` turned out to be because when a symbol is read by the reader,
-it has a null character appended as its last character, after all the visibly
-printing characters. When the type string is being generated, it doesn't. I've
-fudged this for now by giving the type strings an appended null character, but
-the right solution is almost certainly to not add the null character in either
-case — i.e. revert today's 'fix' and instead fix the reader.
-
-I've also done a lot of documentation, and I've found the courage to do some
-investigation on the bignum bug. However, I've workeg until 04:00, which is
-neither sane nor healthy, so I shall stop.
-
-## 20260225
-
-A productive day!
-
-I awoke with a plan to fix `cond`. This morning, I execoted it, and it worked.
-This afternoon, I fixed `let`. And this evening, I greatly improved `equal`.
-
-The bug in `member` is still unresolved.
-
-We're getting very close to the release of 0.0.6.
-
-## 20260224
-
-Found a bug in subtraction, which I hoped might be a clue into the bignum bug;
-but it proved just to be a careless bug in the small integer cache code (and
-therefore a new regression). Fixed this one, easily.
-
-In the process spotted a new bug in subtracting rationals, which I haven't yet
-looked at.
-
-Currently working on a bug which is either in `let` or `cond`, which is leading
-to non-terminating recursion...
-
-H'mmm, there are bugs in both.
-
-#### `let`
-
-The unit test for let is segfaulting. That's a new regression today, because in
-last night's buildv it doesn't segfault. I don't know what's wrong, but to be
-honest I haven't looked very hard because I'm trying to fix the bug in `cond`.
-
-#### `cond`
-
-The unit test for `cond` still passes, so the bug that I'm seeing is not
-triggered by it. So it's not necessarily a new bug. What's happening? Well,
-`member` doesn't terminate.
-
-The definition is as follows:
-
-```lisp
-(set! nil?
- (lambda
- (o)
- "`(nil? object)`: Return `t` if object is `nil`, else `t`."
- (= o nil)))
-
-(set! member
- (lambda
- (item collection)
- "`(member item collection)`: Return `t` if this `item` is a member of this `collection`, else `nil`."
- (cond
- ((nil? collection) nil)
- ((= item (car collection)) t)
- (t (member item (cdr collection))))))
-```
-
-In the execution trace, with tracing of bind, eval and lambda enabled, I'm
-seeing this loop on the stack:
-
-```
-Stack frame with 1 arguments:
- Context: <= (member item (cdr collection)) <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA"
-Arg 0: CONS count: 6 value: (member item (cdr collection))
-Stack frame with 3 arguments:
- Context: <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA" <= (member item (cdr collection))
-Arg 0: CONS count: 7 value: ((nil? collection) nil)
-Arg 1: CONS count: 7 value: ((= item (car collection)) t)
-Arg 2: CONS count: 7 value: (t (member item (cdr collection)))
-Stack frame with 1 arguments:
- Context: <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA" <= (member item (cdr collection)) <= ((nil? collection) nil)
-Arg 0: CONS count: 8 value: (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection))))
-Stack frame with 2 arguments:
- Context: <= "LMDA" <= (member item (cdr collection)) <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection))))
-Arg 0: STRG count: 19 value: "LMDA"
-Arg 1: NIL count: 4294967295 value: nil
-Stack frame with 1 arguments:
- Context: <= (member item (cdr collection)) <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA"
-Arg 0: CONS count: 6 value: (member item (cdr collection))
-Stack frame with 3 arguments:
- Context: <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA" <= (member item (cdr collection))
-Arg 0: CONS count: 7 value: ((nil? collection) nil)
-Arg 1: CONS count: 7 value: ((= item (car collection)) t)
-Arg 2: CONS count: 7 value: (t (member item (cdr collection)))
-Stack frame with 1 arguments:
- Context: <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection)))) <= "LMDA" <= (member item (cdr collection)) <= ((nil? collection) nil)
-Arg 0: CONS count: 8 value: (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection))))
-Stack frame with 2 arguments:
- Context: <= "LMDA" <= (member item (cdr collection)) <= ((nil? collection) nil) <= (cond ((nil? collection) nil) ((= item (car collection)) t) (t (member item (cdr collection))))
-Arg 0: STRG count: 19 value: "LMDA"
-Arg 1: NIL count: 4294967295 value: nil
-```
-
-This then just goes on, and on, and on. The longest instance I've got the trace of wound up more than a third of a million stack frames before I killed it. What appears to be happening is that the cond clause
-
-```lisp
-((nil? collection) nil)
-```
-
-Executes correctly and returns nil; but that instead of terminating the cond expression at that point it continues and executes the following two clauses, resulting in (infinite) recursion.
-
-This is bad.
-
-But what's worse is that the clause
-
-```lisp
-((= item (car collection)) t)
-```
-
-also doesn't terminate the `cond` expression, even when it should.
-
-And the reason? From the trace, it appears that clauses *never* succeed. But if that's true, how come the unit tests are passing?
-
-Problem for another day.
-
-I'm not going to commit today's work to git, because I don't want to commit something I know segfaults.
-
-## 20260220
-
-### State of the build
-
-The only unit tests that are failing now are the bignum tests, which I have
-consciously parked as a future problem, and the memory leak, similarly. The
-leak is a lot less bad than it was, but I'm worried that stack frames
-are not being freed.
-
-If you run
-
-```
-cat lisp/fact.lisp | target/psse -d 2>&1 |\
- grep 'Vector space object of type' | sort | uniq -c | sort -rn
-```
-
-you get a huge number (currently 394) of stack frames in the memory dump; they
-should all have been reclaimed. There's other stuff in the memory dump as well,
-
-```
- 422 CONS ;; cons cells, obviously
- 394 VECP ;; pointers to vector space objects -- specifically, the stack frames
- 335 SYMB ;; symbols
- 149 INTR ;; integers
- 83 STRG ;; strings
- 46 FUNC ;; primitive (i.e. written in C) functions
- 25 KEYW ;; keywords
- 10 SPFM ;; primitive special forms
- 3 WRIT ;; write streams: `*out*`, `*log*`, `*sink*`
- 1 TRUE ;; t
- 1 READ ;; read stream: `*in*`
- 1 NIL ;; nil
- 1 LMDA ;; lambda function, specifically `fact`
-```
-
-Generally, for each character in a string, symbol or keyword there will be one
-cell (`STRG`, `SYMB`, or `KEYW`) cell, so the high number of STRG cells is not
-especially surprising. It looks as though none of the symbols bound in the
-oblist are being recovered on exit, which is undesirable but not catastrophic,
-since it's a fixed burden of memory which isn't expanding.
-
-But the fact that stack frames aren't being reclaimed is serious.
-
-### Update, 19:31
-
-Right, investigating this more deeply, I found that `make_empty_frame` was doing
-an `inc_ref` it should not have been, Having fixed that I'm down to 27 frames
-left in the dump. That's very close to the number which will be generated by
-running `(fact 25)`, so I expect it is now only stack frames for interpreted
-functions which are not being reclaimed. This give me something to work on!
-
-
-## 20260215
-
-Both of yesterday's regressions are fixed. Memory problem still in much the
-same state.
-
-> Allocation summary: allocated 1210; deallocated 10; not deallocated 1200.
-
-That left the add ratios problem which was deeper. I had unintended unterminated
-recursion happening there. :-(
-
-It burned through 74 cons pages each of 1,024 cons cells, total 76,800 cells,
-and 19,153 stack frames. before it got there; and then threw the exception back
-up through each of those 19,153 stack frames. But the actual exception message
-was `Unrecognised tag value 0 ( )`, which is not enormously helpful.
-S
-However, once I had recognised what the problem was, it was quickly fSixed, with
-the added bonus that the new solution will automatically work for bignum
-fractions once bignums are working.
-
-So we're down to eight unit tests failing: the memory leak, one unimplemented
-feature, and the bignum problem.
-
-At the end of the day I decided to chew up some memory by doing a series of
-moderately large computations, to see how much memory is being successfully
-deallocated.
-
-```lisp
-:: (mapcar fact '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
-
-(1 2 6 24 120 720 5,040 40,320 362,880 3,628,800 39,916,800 479,001,600
-1,932,053,504 1,278,945,280 2,004,310,016 2,004,189,184 4,006,445,056
-3,396,534,272 109,641,728 2,192,834,560)
-::
-
-Allocation summary: allocated 10136; deallocated 548; not deallocated 9588.
-```
-
-So, about 5%. This is still a major problem, and is making me doubt my reference
-counting strategy. Must do better!
-
-Note that the reason that the numbers become eratic past about two billion is
-the bignum arithmetic bug.
-
-## 20260214
-
-### Memory leaks
-
-The amount I'm leaking memory is now down by an order of magnitude, but the problem is not fixed.
-Better, not good enough. And although I'm aware of the amount to which Lisp objects are not being
-reclaimed, there may also be transient C objects — cheifly strings — which are also
-not being freed. This is an ongoing process.
-
-But you'll remember that a week ago my base case was:
-
-> Allocation summary: allocated 19986; deallocated 245; not deallocated 19741.
-
-Now it's
-
-> Allocation summary: allocated 1188; deallocated 10; not deallocated 1178.
-
-That is better.
-
-### Unit tests
-
-The unit test system got into a mess because the bignum tests are failing. But because I know
-some tests are failing, and the bignum problem feels so intractable that I don't want to
-tackle it, I've been ignoring the fact that tests are failing; which means I've
-missed regressions — until I started to get an 'Attempt to take value of unbound symbol'
-exception for `nil`, which is extremely serious and broke a lot of things.
-
-That arose out of work on the 'generalised key/value stores' feature, logged under
-[#20260203](20260203), below. However, because I wasn't paying attention to failing tests, it
-took me a week to find and fix it.
-
-But I've fixed that one. And I've put a lot of work into [cleaning up the unit tests](https://git.journeyman.cc/simon/post-scarcity/commit/222368bf640a0b79d57322878dee42ed58b47bd6).
-There is more work to do on this.
-
-### Documentation
-
-I'm also gradually working through cleaning up documentation.
-
-### Regressions
-
-Meantime we have some regressions which are serious, and must be resolved.
-
-#### equals
-
-The core function `equals` is now failing, at least for integers. Also.
-
-```lisp
-(= 0.75 3/4)
-```
-
-fails because I've never implemented a method for it, which I ought.
-
-#### cond
-
-The current unit test for `cond` and that for `recursion` both fail but *I think* this is because `equals` is failing.
-
-#### rational arithmetic
-
-I have a horrible new regression in rational arithmetic which looks as though something is being freed when it shouldn't be.
-
-#### All tests failing as at 20260214
-
-As follows:
-
-1. unit-tests/bignum-expt.sh => (expt 2 61): Fail: expected '2305843009213693952', got ''
-2. unit-tests/bignum-expt.sh => (expt 2 64): Fail: expected '18446744073709551616', got ''
-3. unit-tests/bignum-expt.sh => (expt 2 65): Fail: expected '36893488147419103232', got ''
-4. unit-tests/bignum-print.sh => unit-tests/bignum-print.sh => printing 576460752303423488: Fail: expected '576460752303423488', got '0'
-5. unit-tests/bignum-print.sh => printing 1152921504606846976: Fail: expected '1152921504606846976', got '0'
-6. unit-tests/bignum-print.sh => printing 1152921504606846977: Fail: expected '1152921504606846977', got '1'
-7. unit-tests/bignum-print.sh => printing 1329227995784915872903807060280344576: Fail: expected '1329227995784915872903807060280344576', \n got '0'
-8. unit-tests/bignum.sh => unit-tests/bignum.sh => Fail: expected '1,152,921,504,606,846,976', got '0'
-9. unit-tests/bignum-subtract.sh => unit-tests/bignum-subtract.sh => subtracting 1 from 1152921504606846976: Fail: expected '1152921504606846975', got '4294967295'
-10. unit-tests/bignum-subtract.sh => subtracting 1 from 1152921504606846977: Fail: expected '1152921504606846976', got '0'
-11. unit-tests/bignum-subtract.sh => subtracting 1 from 1152921504606846978: Fail: expected '1152921504606846977', got '1'
-12. unit-tests/bignum-subtract.sh => subtracting 1152921504606846977 from 1: Fail: expected '-1152921504606846976', got '0'
-13. unit-tests/bignum-subtract.sh => subtracting 10000000000000000000 from 20000000000000000000: Fail: expected '10000000000000000000', got '2313682944'
-14. unit-tests/cond.sh => unit-tests/cond.sh: cond with one clause... Fail: expected '5', got 'nil'
-15. unit-tests/memory.sh => Fail: expected '1188', got '10'
-16. unit-tests/ratio-addition.sh => Fail: expected '1/4', got 'Error: Unrecognised tag value 4539730 ( REE)'
-17. unit-tests/recursion.sh => Fail: expected 'nil 3,628,800', got ''
-
-### New master version
-
-I haven't done a 'release' of Post Scarcity since September 2021, because I've
-been so despondent about the bignum problem. But actually a lot of this *is*
-usable, and it's at least sufficiently intereting that other people might want
-to play with it, and possibly even might fix some bugs.
-
-So I'm currently planning to release a new master before the end of this month,
-and publicise it.
-
-## 20260204
-
-### Testing what is leaking memory
-
-#### Analysis
-
-If you just start up and immediately abort the current build of psse, you get:
-
-> Allocation summary: allocated 19986; deallocated 245; not deallocated 19741.
-
-Allocation summaries from the current unit tests give the following ranges of values:
-
-| | Min | Max | |
-| --------------- | ----- | ----- | ---- |
-| Allocated | 19991 | 39009 | |
-| Deallocated | 238 | 1952 | |
-| Not deallocated | 19741 | 37057 | |
-
-The numbers go up broadly in sinc with one another — that is to say, broadly, as the number allocated rises, so do both the numbers deallocated and the numbers not deallocated. But not exactly.
-
-#### Strategy: what doesn't get cleaned up?
-
-Write a test wrapper which reads a file of forms, one per line, from standard input, and passes each in turn to a fresh invocation of psse, reporting the form and the allocation summary.
-
-```bash
-#1/bin/bash
-
-while IFS= read -r form; do
- allocation=`echo ${form} | ../../target/psse 2>&1 | grep Allocation`
- echo "* ${allocation}: ${form}"
-done
-```
-
-So, from this:
-
-* Allocation summary: allocated 19986; deallocated 245; not deallocated 19741.:
-* Allocation summary: allocated 19990; deallocated 249; not deallocated 19741.: ()
-* Allocation summary: allocated 20019; deallocated 253; not deallocated 19766.: nil
-
-Allocating an empty list allocates four additional cells, all of which are deallocated. Allocating 'nil' allocates a further **29** cells, 25 of which are not deallocated. WTF?
-
-Following further work I have this, showing the difference added to the base case of cells allocated, cells deallocated, and, most critically, cells not deallocated.
-
-From this we see that reading and printing `nil` allocates an additional 33 cells, of which eight are not cleaned up. That's startling, and worrying.
-
-But the next row shows us that reading and printing an empty list costs only four cells, each of which is cleaned up. Further down the table we see that an empty map is also correctly cleaned up. Where we're leaking memory is in reading (or printing, although I doubt this) symbols, either atoms, numbers, or keywords (I haven't yet tried strings, but I expect they're similar.)
-
-| **Case** | **Delta Allocated** | **Delta Deallocated** | **Delta Not Deallocated** |
-| --------------------------------- | ------------------- | --------------------- | ------------------------- |
-| **Basecase** | 0 | 0 | 0 |
-| **nil** | 33 | 8 | 25 |
-| **()** | 4 | 4 | 0 |
-| **(quote ())** | 39 | 2 | 37 |
-| **(list )** | 37 | 12 | 25 |
-| **(list 1)** | 47 | 14 | 33 |
-| **(list 1 1)** | 57 | 16 | 41 |
-| **(list 1 1 1)** | 67 | 18 | 49 |
-| **(list 1 2 3)** | 67 | 18 | 49 |
-| **(+)** | 36 | 10 | 26 |
-| **(+ 1)** | 44 | 12 | 32 |
-| **(+ 1 1)** | 53 | 14 | 39 |
-| **(+ 1 1 1)** | 62 | 16 | 46 |
-| **(+ 1 2 3)** | 62 | 16 | 46 |
-| **(list 'a 'a 'a)** | 151 | 33 | 118 |
-| **(list 'a 'b 'c)** | 151 | 33 | 118 |
-| **(list :a :b :c)** | 121 | 15 | 106 |
-| **(list :alpha :bravo :charlie)** | 485 | 15 | 470 |
-| **{}** | 6 | 6 | 0 |
-| **{:z 0}** | 43 | 10 | 33 |
-| **{:zero 0}** | 121 | 10 | 111 |
-| **{:z 0 :o 1}** | 80 | 11 | 69 |
-| **{:zero 0 :one 1}** | 210 | 14 | 196 |
-| **{:z 0 :o 1 :t 2}** | 117 | 12 | 105 |
-
-Looking at the entries, we see that
-
-1. each number read costs ten allocations, of which only two are successfully deallocated;
-2. the symbol `list` costs 33 cells, of which 25 are not deallocated, whereas the symbol `+` costs only one cell fewer, and an additional cell is not deallocated. So it doesn't seem that cell allocation scales with the length of the symbol;
-3. Keyword allocation does scale with the length of the keyword, apparently, since `(list :a :b :c)` allocates 121 and deallocates 15, while `(list :alpha :bravo :charlie)` allocates 485 and deallocates the same 15;
-4. The fact that both those two deallocate 15, and a addition of three numbers `(+ 1 2 3)` or `(+ 1 1 1)` deallocates 16 suggest to me that the list structure is being fully reclaimed but atoms are not being.
-5. The atom `'a` costs more to read than the keyword `:a` because the reader macro is expanding `'a` to `(quote a)` behind the scenes.
-
-### The integer allocation bug
-
-Looking at what happens when we read a single digit number, we get the following:
-
-```
-2
-Entering make_integer
-Allocated cell of type 'INTR' at 19, 507
-make_integer: returning
- INTR (1381256777) at page 19, offset 507 count 0
- Integer cell: value 0, count 0
-Entering make_integer
-Allocated cell of type 'INTR' at 19, 508
-make_integer: returning
- INTR (1381256777) at page 19, offset 508 count 0
- Integer cell: value 10, count 0
-Entering make_integer
-Allocated cell of type 'INTR' at 19, 509
-make_integer: returning
- INTR (1381256777) at page 19, offset 509 count 0
- Integer cell: value 2, count 0
-Entering make_integer
-Allocated cell of type 'INTR' at 19, 510
-make_integer: returning
- INTR (1381256777) at page 19, offset 510 count 0
- Integer cell: value 0, count 0
-Entering make_integer
-Allocated cell of type 'INTR' at 19, 506
-make_integer: returning
- INTR (1381256777) at page 19, offset 506 count 0
- Integer cell: value 0, count 0
-Entering make_integer
-Allocated cell of type 'INTR' at 19, 505
-make_integer: returning
- INTR (1381256777) at page 19, offset 505 count 0
- Integer cell: value 0, count 0
-Entering make_integer
-Allocated cell of type 'INTR' at 19, 504
-make_integer: returning
- INTR (1381256777) at page 19, offset 504 count 0
- Integer cell: value 0, count 0
-
-Allocated cell of type 'STRG' at 19, 503
-Freeing cell STRG (1196577875) at page 19, offset 503 count 0
- String cell: character '2' (50) with hash 0; next at page 0 offset 0, count 0
- value: "2"
-Freeing cell INTR (1381256777) at page 19, offset 504 count 0
- Integer cell: value 2, count 0
-2
-Allocated cell of type 'SYMB' at 19, 504
-Allocated cell of type 'SYMB' at 19, 503
-Allocated cell of type 'SYMB' at 19, 502
-Allocated cell of type 'SYMB' at 19, 501
-Freeing cell SYMB (1112365395) at page 19, offset 501 count 0
- Symbol cell: character '*' (42) with hash 485100; next at page 19 offset 502, count 0
- value: *in*
-Freeing cell SYMB (1112365395) at page 19, offset 502 count 0
- Symbol cell: character 'i' (105) with hash 11550; next at page 19 offset 503, count 0
- value: in*
-Freeing cell SYMB (1112365395) at page 19, offset 503 count 0
- Symbol cell: character 'n' (110) with hash 110; next at page 19 offset 504, count 0
- value: n*
-Freeing cell SYMB (1112365395) at page 19, offset 504 count 0
- Symbol cell: character '*' (42) with hash 0; next at page 0 offset 0, count 0
- value: *
-```
-
-Many things are worrying here.
-
-1. The only thing being freed here is the symbol to which the read stream is bound — and I didn't see where that got allocated, but we shouldn't be allocating and tearing down a symbol for every read! This implies that when I create a string with `c_string_to_lisp_string`, I need to make damn sure that that string is deallocated as soon as I'm done with it — and wherever I'm dealing with symbols which will be referred to repeatedly in `C` code, I need either
- 1. to bind a global on the C side of the world, which will become messy;
- 2. or else write a hash function which returns, for a `C` string, the same value that the standard hashing function will return for the lexically equivalent `Lisp` string, so that I can search hashmap structures from C without having to allocate and deallocate a fresh copy of the `Lisp` string;
- 3. In reading numbers, I'm generating a fresh instance of `Lisp zero` and `Lisp ten`, each time `read_integer` is called, and I'm not deallocating them.
- 4. I am correctly deallocating the number I did read, though!
-
-## 20260203
-
-I'm consciously avoiding the bignum issue for now. My current thinking is that if the C code only handles 64 bit integers, and bignums have to be done in Lisp code, that's perfectly fine with me.
-
-### Hashmaps, assoc lists, and generalised key/value stores
-
-I now have the oblist working as a hashmap, and also hybrid assoc lists which incorporate hashmaps working. I don't 100% have consistent methods for reading stores which may be plain old assoc lists, new hybrid assoc lists, or hashmaps working but it isn't far off. This also takes me streets further towards doing hierarchies of hashmaps, allowing my namespace idea to work — and hybrid assoc lists provide a very sound basis for building environment structures.
-
-Currently all hashmaps are mutable, and my doctrine is that that is fixable when access control lists are actually implemented.
-
-#### assoc
-
-The function `(assoc store key) => value` should be the standard way of getting a value out of a store.
-
-#### put!
-
-The function `(put! store key value) => store` should become the standard way of setting a value in a store (of course, if the store is an assoc list or an immutable map, a new store will be returned which holds the additional key/value binding).
-
-### State of unit tests
-
-Currently:
-
-> Tested 45, passed 39, failed 6
-
-But the failures are as follows:
-```
-unit-tests/bignum-add.sh => checking a bignum was created: Fail
-unit-tests/bignum-add.sh => adding 1152921504606846977 to 1: Fail: expected 't', got 'nil'
-unit-tests/bignum-add.sh => adding 1 to 1152921504606846977: Fail: expected 't', got 'nil'
-unit-tests/bignum-add.sh => adding 1152921504606846977 to 1152921504606846977: Fail: expected 't', got 'nil'
-unit-tests/bignum-add.sh => adding 10000000000000000000 to 10000000000000000000: Fail: expected 't', got 'nil'
-unit-tests/bignum-add.sh => adding 1 to 1329227995784915872903807060280344576: Fail: expected 't', got 'nil'
-unit-tests/bignum-add.sh => adding 1 to 3064991081731777716716694054300618367237478244367204352: Fail: expected 't', got 'nil'
-unit-tests/bignum-expt.sh => (expt 2 60): Fail: expected '1152921504606846976', got '1'
-unit-tests/bignum-expt.sh => (expt 2 61): Fail: expected '2305843009213693952', got '2'
-unit-tests/bignum-expt.sh => (expt 2 64): Fail: expected '18446744073709551616', got '16'
-unit-tests/bignum-expt.sh => (expt 2 65): Fail: expected '36893488147419103232', got '32'
-unit-tests/bignum-print.sh => printing 1152921504606846976: Fail: expected '1152921504606846976', got '1'
-unit-tests/bignum-print.sh => printing 1152921504606846977: Fail: expected '1152921504606846977', got '2'
-unit-tests/bignum-print.sh => printing 1329227995784915872903807060280344576: Fail: expected '1329227995784915872903807060280344576', \n got '1151321504605245376'
-unit-tests/bignum.sh => unit-tests/bignum.sh => Fail: expected '1,152,921,504,606,846,976', got '1'
-unit-tests/bignum-subtract.sh => unit-tests/bignum-subtract.sh => subtracting 1 from 1152921504606846976: Fail: expected '1152921504606846975', got '0'
-unit-tests/bignum-subtract.sh => subtracting 1 from 1152921504606846977: Fail: expected '1152921504606846976', got '1'
-unit-tests/bignum-subtract.sh => subtracting 1 from 1152921504606846978: Fail: expected '1152921504606846977', got '2'
-unit-tests/bignum-subtract.sh => subtracting 1152921504606846977 from 1: Fail: expected '-1152921504606846976', got '1'
-unit-tests/bignum-subtract.sh => subtracting 10000000000000000000 from 20000000000000000000: Fail: expected '10000000000000000000', got '-376293541461622793'
-unit-tests/memory.sh
-```
-
-In other words, all failures are in bignum arithmetic **except** that I still have a major memory leak due to not decrefing somewhere where I ought to.
-
-### Zig
-
-I've also experimented with autotranslating my C into Zig, but this failed. Although I don't think C is the right language for implementing my base Lisp in, it's what I've got; and until I can get some form of autotranslate to bootstrap me into some more modern systems language, I think I need to stick with it.
-
-## 20250704
-
-Right, I'm getting second and subsequent integer cells with negative values, which should not happen. This is probably the cause of (at least some of) the bignum problems. I need to find out why. This is (probably) fixable.
-
-```lisp
-:: (inspect 10000000000000000000)
-
- INTR (1381256777) at page 3, offset 873 count 2
- Integer cell: value 776627963145224192, count 2
- BIGNUM! More at:
- INTR (1381256777) at page 3, offset 872 count 1
- Integer cell: value -8, count 1
-```
-
-Also, `print` is printing bignums wrong on ploughwright, but less wrong on mason, which implies a code difference. Investigate.
-
-## 20250314
-
-Thinking further about this, I think at least part of the problem is that I'm storing bignums as cons-space objects, which means that the integer representation I can store has to fit into the size of a cons pointer, which is 64 bits. Which means that to store integers larger than 64 bits I need chains of these objects.
-
-If I stored bignums in vector space, this problem would go away (especially as I have not implemented vector space yet).
-
-However, having bignums in vector space would cause a churn of non-standard-sized objects in vector space, which would mean much more frequent garbage collection, which has to be mark-and-sweep because unequal-sized objects, otherwise you get heap fragmentation.
-
-So maybe I just have to put more work into debugging my cons-space bignums.
-
-Bother, bother.
-
-There are no perfect solutions.
-
-However however, it's only the node that's short on vector space which has to pause to do a mark and sweep. It doesn't interrupt any other node, because their reference to the object will remain the same, even if it is the 'home node' of the object which is sweeping. So all the node has to do is set its busy flag, do GC, and clear its busy flag, The rest of the system can just be carrying on as normal.
-
-So... maybe mark and sweep isn't the big deal I think it is?
-
-## 20250313
-
-OK, the 60 bit integer cell happens in `int128_to_integer` in `arith/integer.c`. It seems to be being done consistently; but there is no obvious reason. `MAX_INTEGER` is defined in `arith/peano.h`. I've changed both to use 63 bits, and this makes no change to the number of unit tests that fail.
-
-With this change, `(fact 21)`, which was previously printing nothing, now prints a value, `11,891,611,015,076,642,816`. However, this value is definitively wrong, should be `51,090,942,171,709,440,000`. But, I hadn't fixed the shift in `integer_to_string`; have now... still no change in number of failed tests...
-
-But `(fact 21)` gives a different wrong value, `4,974,081,987,435,560,960`. Factorial values returned by `fact` are correct (agree with SBCL running the same code) up to `(fact 20)`, with both 60 bit integer cells and 63 bit integer cells giving correct values.
-
-Uhhhmmm... but I'd missed two other places where I'd had the number of significant bits as a numeric literal. Fixed those and now `(fact 21)` does not return a printable answer at all, although the internal representation is definitely wrong. So we may be seeing why I chose 60 bits.
-
-Bother.
-
-## 20250312
-
-Printing of bignums definitely doesn't work; I'm not persuaded that reading of bignums works right either, and there are probably problems with bignum arithmetic too.
-
-The internal memory representation of a number rolls over from one cell to two cells at 1152921504606846976, and I'm not at all certain why it does because this is neither 263 nor 264.
-
-| | | |
-| -------------- | -------------------- | ---- |
-| 262 | 4611686018427387904 | |
-| 263 | 9223372036854775808 | |
-| 264 | 18446744073709551616 | |
-| Mystery number | 1152921504606846976 | |
-
-In fact, our mystery number turns out (by inspection) to be 260. But **why**?
diff --git a/docs/Sysout-and-sysin.md b/docs/Sysout-and-sysin.md
deleted file mode 100644
index cabd2e3..0000000
--- a/docs/Sysout-and-sysin.md
+++ /dev/null
@@ -1,19 +0,0 @@
-# Sysout and sysin
-
-We need a mechanism to persist a running system to backing store, and restore it from backing store.
-
-This might, actually, turn out not to be terribly hard, but is potentially horrendous, particularly if we're talking about very large (multi-terabyte) memory images.
-
-If we use paged memory, as many UNIX systems do, then memory pages periodically get written to disk and the sum total of the memory pages on disk represent an image of the state of system memory. The problem with this is that the state of system memory is changing all the time, and if some pages are out of date with respect to others you don't have a consistent image.
-
-However, the most volatile area of memory is at the outer end of [cons space](Cons-space.html), since that is where cons cells are most likely to die and consequently where new cons cells are most likely to be allocated. We could conceivably take advantage of this by maintaining a per-page [free list](Free-list.html), and preferentially allocating from the currently busiest page. Volatility in [vector space](Vector-space.html) is likely to be significantly lower, but significantly more distributed. However, if we stick to the general rule that objects aren't mutable, volatility happens only by allocating new objects or deallocating old ones. So it may be the case that if we make a practice of flushing vector space pages when that page is written to, and flushing the active cons space pages regularly, we may at any time achieve a consistent memory image on disk even if it misses the last few seconds worth of changes in cons space.
-
-Otherwise it's worth looking at whether we could journal changes between page flushes. This may be reasonably inexpensive.
-
-If none of this works then persisting the system to backing media may mean halting the system, compacting vector space, writing the whole of active memory to a stream, and restarting the system. This is extremely undesirable because it means putting the system offline for a potentially extended period.
-
------
-
-Actually, I'm not sure the above works at all. To sysout a running system, you'd have to visit each node in turn and serialise its cons and vector pages. But if the system is still running when you do this, then you would probably end up with an inconsistent sysout. So you'd have to signal all nodes to halt before performing sysout. Further, you could not restore a sysout to a system with a smaller node count, or smaller node memory, to the system dumped.
-
-This is tricky!
\ No newline at end of file
diff --git a/docs/System-private-functions.md b/docs/System-private-functions.md
deleted file mode 100644
index c0b3eea..0000000
--- a/docs/System-private-functions.md
+++ /dev/null
@@ -1,14 +0,0 @@
-# System private functions
-
-**actually, I think this is a bad idea — or at least needs significantly more thought!**
-
-System-private functions are functions private to the system, which no normal user is entitled to access; these functions normally have an [access control](Access-control.html) value of NIL.
-
-# (sys-access-control arg)
-
-System private. Takes one argument. Returns the access control list of its argument.
-
-# (sys-readable arg user)
-
-System private. Takes two arguments. Returns `TRUE` if the first argument is readable by the reader represented by the second argument; else `NIL`.
-
diff --git a/docs/Topology-of-the-hardware-of-the-deep-future.md b/docs/Topology-of-the-hardware-of-the-deep-future.md
deleted file mode 100644
index 0cdc541..0000000
--- a/docs/Topology-of-the-hardware-of-the-deep-future.md
+++ /dev/null
@@ -1,39 +0,0 @@
-# On the topology of the hardware of the deep future
-
-
-
-In thinking about how to write a software architecture that won't quickly become obsolescent, I find that I'm thinking increasingly about the hardware on which it will run.
-
-In [Post Scarcity Hardware](Post-scarcity-hardware.html) I envisaged a single privileged node which managed main memory. Since then I've come to thing that this is a brittle design which will lead to bottle necks, and that each cons page will be managed by a separate node. So there needs to be a hardware architecture which provides the shortest possible paths between nodes.
-
-Well, actually... from a software point of view it doesn't matter. From a software point of view, provided it's possible for any node to request a memory item from any other node, that's enough, and, for the software to run (slowly), a linear serial bus would do. But part of the point of this thinking is to design hardware which is orders of magnitude faster than the [von Neumann architecture](https://en.wikipedia.org/wiki/Von_Neumann_architecture) allows. So for performance, cutting the number of hops to a minimum is important.
-
-I've been reading Danny Hillis' [thesis](https://dspace.mit.edu/bitstream/handle/1721.1/14719/18524280-MIT.pdf?sequence=2) and his book [The Connection Machine](https://books.google.co.uk/books/about/The_Connection_Machine.html?id=xg_yaoC6CNEC&redir_esc=y&hl=en) which, it transpires, is closely based on it. Danny Hillis was essentially trying to do what I am trying to do, but forty years ago, with the hardware limitations of forty years ago (but he was trying to do it in the right place, and with a useful amount of money that actually allowed him to build something physical, which I'm never likely to have).
-
-Hillis' solution to the topology problem, as I understand it (and note - I may not understand it very well) is as follows:
-
-
-
-If you take a square grid and place a processor at every intersection, it has at most four proximal neighbours, and, for a grid which is `x` cells in each direction, the longest path between two cells is `2x`. If you join the nodes on the left hand edge of the grid to the corresponding nodes on the right hand edge, you have a cylinder, and the longest path between two nodes is 1.5x. If you then join the nodes on the top of the grid to the nodes on the bottom, you have a torus - a figure like a doughnut or a bagel. Every single node has four proximal neighbours, and the longest path between any two nodes is `x`.
-
-So far so good. Now, let's take square grids and stack them. This gives each node at most six proximal neighbours. We form a cube, and the longest distance between two nodes is `3x`. We can link the nodes on the left of the cube to the corresponding nodes on the right and form a (thick walled) cylinder, and the longest distance between two nodes is `2.5x`. Now join the nodes at the top of the cube to the corresponding nodes at the bottom, and we have a thick walled torus. The maximum distance between is now `2x`.
-
-Let's stop for a moment and think about the difference between logical and physical topology. Suppose we have a printed circuit board with 199 processors on it in a regular grid. We probably could physically bend the circuit board to form a cylinder, but there's no need to do so. We achieve exactly the same connection architecture simply by using wires to connect the left side to the right. And if we use wires to connect those at the top with those at the bottom, we've formed a logical torus even though the board is still flat.
-
-It doesn't even need to be a square board. We could have each processor on a separate board in a rack, with each board having four connectors probably all along the same edge, and use patch wires to connect the boards together into a logical torus.
-
-So when we're converting our cube into a torus, the 'cube' *could* consist of a vertical stack of square boards each of which has a grid of processors on it. But it could also consist of a stack of boards in a rack, each of which has six connections, patched together to form the logical thick-walled torus. So now lets take additional patch leads and join the nodes that had been on the front of the logical cube to the corresponding nodes on the back of the logical cube, and we have a topology which has some of the properties of a torus and some of the properties of a sphere, and is just mind-bending if you try to visualise it.
-
-This shape is what I believe Hillis means by a [hypercube](https://en.wikipedia.org/wiki/Hypercube), although I have to say I've never found any of the visualisations of a hypercube in books or on the net at all helpful, and they certainly don't resemble the torusy-spherey thing I which visualise.
-
-It has the very useful property, however, that the longest distance between any two nodes is `1.5x`.
-
-Why is `1.5x` on the hypercube better than `1x` on the torus? Suppose you want to build a machine with about 1000 nodes. The square root of a thousand is just less than 32, so let's throw in an extra 24 nodes to make it a round 32. We can lay out 1024 nodes on a 32 x 32 square, join left to right, top to bottom, and we have a maximum path between two of 1024 nodes of 32 hops. Suppose instead we arrange our processors on ten boards each ten by ten, with vertical wires connecting each processor with the one above it and the one below it, as well tracks on the board linking each with those east, west, north and south. Connect the left hand side to the right, the front to the back and the top to the bottom, and we have a maximum path between any two of 1000 nodes of fifteen hops. That's twice as good.
-
-Obviously, if you increase the number of interconnectors to each processor above six, the paths shorten further but the logical topology becomes even harder to visualise. This doesn't matter - it doesn't actually have to be visualised - but wiring would become a nightmare.
-
-I've been thinking today about topologies which would allow higher numbers of connections and thus shorter paths, and I've come to this tentative conclusion.
-
-I can imagine topologies which tesselate triangle-tetrahedron-hypertetrahedron and pentagon-dodecahedron-hyperdodecahedron. There are possibly others. But the square-cube-hypercube model has one important property that those others don't (or, at least, it isn't obvious to me that they do). In the square-cube-hypercube model, every node can be addressed by a fixed number of coordinates, and the shortest path from any node to any other is absolutely trivial to compute.
-
-From this I conclude that the engineers who went before me - and who were a lot more thoughtful and expert than I am - were probably right: the square-cube-hypercube model, specifically toruses and hypercubes, is the right way to go.
\ No newline at end of file
diff --git a/docs/Users.md b/docs/Users.md
deleted file mode 100644
index a6bd5ad..0000000
--- a/docs/Users.md
+++ /dev/null
@@ -1,9 +0,0 @@
-# Users
-
-I'm not yet sure what sort of objects users are. They may just be lists, interned in a special namespace such as *system.users*. They may be special purpose [vector space](Vector-space.html) objects (although I don't see why, apart from to get a special tag, which might be useful).
-
-Every user object must contain credentials, and the credentials must be readable by system only; the credentials are either a hashed password or a cryptographic public key. The user object must also have an identifying name, and probably other identifying information. But it's not necessarily the case that every user on the system needs to be able to see the names of every other user on the system, so the identifying information (or the user object itself) may have [access control](Access-control.html) lists.
-
-There is a problem here with the principle of [immutability](Immutability.html); if an access control list on an object _foo_ contains a pointer to my user object so that I can read _foo_, and I change my password, then the immutability rule says that a new copy of the *system.users* namespace is created with a new copy of my user object. This new user object isn't on any access control list so by changing my password I actually can't read anything.
-
-This means that what we put on access control lists is not user objects, but symbols (usernames) which are bound in *system.users* to user objects; the user object then needs a back-pointer to that username. A user group then becomes a list not of user objects but of interned user names.
\ No newline at end of file
diff --git a/docs/Vector-space.md b/docs/Vector-space.md
deleted file mode 100644
index 528b04c..0000000
--- a/docs/Vector-space.md
+++ /dev/null
@@ -1,80 +0,0 @@
-# Vector Space
-
-Vector space is what in conventional computer languages is known as 'the heap'. Because objects allocated in vector space are of variable size, vector space will fragment over time. Objects in vector space will become unreferenced, making them available for garbage collection and reallocation; but ultimately you will arrive at the situation where there are a number of small free spaces in vector space but you need a large one. Therefore there must ultimately be a mark-and-sweep garbage collector for vector space.
-
-To facilitate this, reference to every vector space object will be indirected through exactly one VECP object in [cons space](Cons-space.html). If a live vector space object has to be moved in memory in order to compact the heap and to allocate a new object, only one pointer need be updated. This saves enormously on mark-and-sweep time, at the expense of a small overhead on access to vector space objects.
-
-Every vector space object must have a header, indicating that it is a vector space object and what sort of a vector space object it is. Each vector space object must have a fixed size, which is declared in its header. Beyond the header, the payload of a vector space object is undetermined.
-
-Note that, if cons-pointers are implemented simply as memory addresses, the cost of moving a cons page becomes huge, so a rational garbage collector would know about cons pages and do everything possible to avoid moving them.
-
-## The header
-
-As each vector space object has an associated VECP object in cons space, a vector space object does not need to contain either a reference count or an access control list. It does need a cons-pointer to its associated VECP object; it does need a tag (actually it doesn't, since we could put all the tags in cons space, but it is convenient for memory allocation debugging that each should have a tag). It's probably convenient for it to have a mark bit, since if garbage collection of vector space is implemented at all it needs to be mark-and-sweep.
-
-So the header looks like this
-
- +-----+--------------+------+------+--------------+
- | tag | vecp-pointer | size | mark | payload... /
- +-----+--------------+------+------+------------+
-
-**TODO:** I'm not satisfied with this header design. I think it should be a multiple of 64 bits, so that it is word aligned, for efficiency of fetch. Possibly it would be better to make the *size* field 31 bits with *mark* size one bit, and instead of having the value of *size* being the size of the object in bytes, it should be the size in 64 bit words, even though that makes the maximum allocatable object only 17 gigabytes. It should also be ordered *tag, size, mark, vecp-pointer*, in order to word align the *vecp-pointer* field.
-
-### Tag
-
-The tag will be a 32 bit unsigned integer in the same way and for the same reasons that it is in [cons space](Cons-space.html): i.e., because it will be alternately readable as a four character ASCII string, which will aid memory debugging.
-
-### Vecp-pointer
-
-The vecp pointer is a back pointer to the VECP object in cons space which points to this vector space object. It is, therefore, obviously, the size of a [cons pointer](consspaceobject_8h.html#structcons__pointer), which is to say 64 bits.
-
-### Size
-
-Obviously a single vector space object cannot occupy the whole of memory, since there are other housekeeping things we need to get the system up and running. But there really should not be a reason why a program should not allocate all the remaining available memory as a single object if that's what it wants to do. So the size field should be the width of the address bus of the underlying machine; for the present, 64 bits. The value of the size field will be the whole size, in bytes, of the object including the header.
-
-### Mark
-
-It's probable that in version zero we won't implement garbage collection of vector space. C programs do not normally have any mechanism for compacting their heap; and vector space objects are much less likely than cons space objects to be transient. However, respecting the fact that in the long term we are going to want to be able to compact our vector space, I'll provide a mark field. This really only needs to be one bit, but, again for word alignment, we'll give it a byte.
-
-So the header now looks like this:
-
- +-----+--------------+------+------+------------------------+
- | 0 | 32 | 96 | 160 | 168 ...(167 + size) /
- | tag | vecp-pointer | size | mark | payload... /
- +-----+--------------+------+------+--------------------+
-
-#### Alternative mark-bit strategy
-
-A thought which has recently occurred to me is that the mark bit could be the case bit of the least significant byte of the tag. So that if the tag read 'IMAG' (a raster image), for example, when marked it would read 'IMAg'. This saves having a separately allocated mark in the header, but retains debugging clarity.
-
-## Tags
-
-I really don't at this point have any idea what sorts of things we'll want to store in vector space. This is a non-exhaustive list of things I can think of just now.
-
-### BMAP
-
-A bitmap; a monochrome raster; a two dimensional array of bits.
-
-### EXEC
-
-We definitely need chunks of executable code - compiled functions.
-
-### HASH
-
-We definitely need hashtables. A hashtable is implemented as a pointer to a hashing function, and an array of N cons-pointers each of which points to an [assoc list](Hybrid-assoc-lists.html) acting as a hash bucket. A hashtable is immutable. Any function which 'adds a new key/value pair to' a hashtable in fact returns a new hashtable containing all the key value bindings from the old one, with the new one added. Any function which 'changes a key/value pair' in a hashtable in fact returns a new value with the same bindings of all the keys except the one which has changed as the old one.
-
-In either case, anything which held a pointer to the old version still sees the old version, which continues to exist until everything which pointed to it has been deallocated. Only things which access the hashtable via a binding in a current namespace will see the new version.
-
-### NMSP
-
-A namespace. A namespace is a hashtable with some extra features. It has a parent pointer: NIL in the case of a namespace which was not created by 'adding to' or 'modifying' a pre-existing one, but where a pre-existing one was acted on, then that pre-existing one. It also must have an additional access control list, for users entitled to create new canonical versions of this namespace.
-
-A lot of thinking needs to be done here. It's tricky. If I get it wrong, the cost to either performance or security or both will be horrible.
-
-### RSTR
-
-A raster; a two dimensional array of 32 bit integers, typically interpreted as RGBA colour values.
-
-### VECT
-
-An actual vector; an array with cells of a fixed type (where, obviously, a cons pointer is one type). Has a finite number of dimensions, but probably not more than 4,294,967,296 will be supported (i.e. 32 bits for `dimensions`).
\ No newline at end of file
diff --git a/lisp/defun.lisp b/lisp/defun.lisp
index 3382985..a6d80f5 100644
--- a/lisp/defun.lisp
+++ b/lisp/defun.lisp
@@ -1,8 +1,16 @@
-(set! symbol? (lambda (x) (equal (type x) "SYMB")))
+(set! list (lambda l l))
+
+(set! symbolp (lambda (x) (equal (type x) "SYMB")))
+
+(set! defun!
+ (nlambda
+ form
+ (cond ((symbolp (car form))
+ (set (car form) (apply 'lambda (cdr form))))
+ (t nil))))
(set! defun!
(nlambda
- "`(defun name arg-list forms...)`: Define an interpreted Lambda function with this `name` and this `arg-list`, whose body is comprised of these `forms`."
form
(eval (list 'set! (car form) (cons 'lambda (cdr form))))))
@@ -11,10 +19,10 @@
(set! defsp!
(nlambda
form
- (cond (symbol? (car form))
+ (cond (symbolp (car form))
(set! (car form) (apply nlambda (cdr form))))))
-(defun! cube (x) (* x x x))
+(defsp! cube (x) ((* x x x)))
(set! p 5)
diff --git a/lisp/documentation.lisp b/lisp/documentation.lisp
deleted file mode 100644
index 271700d..0000000
--- a/lisp/documentation.lisp
+++ /dev/null
@@ -1,46 +0,0 @@
-;; This function depends on:
-;; `member` (from file `member.lisp`)
-;; `nth` (from `nth.lisp`)
-;; `string?` (from `types.lisp`)
-
-(set! nil? (lambda
- (o)
- "`(nil? object)`: Return `t` if object is `nil`, else `t`."
- (= o nil)))
-
-(set! member? (lambda
- (item collection)
- "`(member item collection)`: Return `t` if this `item` is a member of this `collection`, else `nil`."
- (print (list "In member? item is " item "; collection is " collection))
- (println)
- (cond
- ((= 0 (count collection)) nil)
- ((= item (car collection)) t)
- (t (member? item (cdr collection))))))
-
-;; (member? (type member?) '("LMDA" "NLMD"))
-
-(set! nth (lambda (n l)
- "Return the `n`th member of this list `l`, or `nil` if none."
- (cond ((= nil l) nil)
- ((= n 1) (car l))
- (t (nth (- n 1) (cdr l))))))
-
-(set! string? (lambda (o) "True if `o` is a string." (= (type o) "STRG") ) )
-
-(set! documentation (lambda (object)
- "`(documentation object)`: Return documentation for the specified `object`, if available, else `nil`."
- (cond ((member? (type object) '("FUNC" "SPFM"))
- (:documentation (meta object)))
- ((member? (type object) '("LMDA" "NLMD"))
- (let ((d . (nth 3 (source object))))
- (cond ((string? d) d)
- (t (source object)))))
- (t object))))
-
-(set! doc documentation)
-
-(documentation apply)
-
-;; (documentation member?)
-
diff --git a/lisp/fact.lisp b/lisp/fact.lisp
index a264b4d..86d452a 100644
--- a/lisp/fact.lisp
+++ b/lisp/fact.lisp
@@ -1,9 +1,7 @@
(set! fact
(lambda (n)
- "Compute the factorial of `n`, expected to be a natural number."
+ "Compute the factorial of `n`, expected to be an integer."
(cond ((= n 1) 1)
(t (* n (fact (- n 1)))))))
-(fact 25)
-
-
+(fact 1000)
diff --git a/lisp/greaterp.lisp b/lisp/greaterp.lisp
deleted file mode 100644
index 2122ccd..0000000
--- a/lisp/greaterp.lisp
+++ /dev/null
@@ -1,3 +0,0 @@
-(set! > (lambda (a b)
- "`(> a b)`: Return `t` if `a` is a number greater than `b`, else `nil`."
- (not (negative? (- a b)))))
\ No newline at end of file
diff --git a/lisp/member.lisp b/lisp/member.lisp
deleted file mode 100644
index dfb12af..0000000
--- a/lisp/member.lisp
+++ /dev/null
@@ -1,14 +0,0 @@
-(set! nil? (lambda
- (o)
- "`(nil? object)`: Return `t` if object is `nil`, else `t`."
- (= o nil)))
-
-(set! member? (lambda
- (item collection)
- "`(member item collection)`: Return `t` if this `item` is a member of this `collection`, else `nil`."
- (cond
- ((nil? collection) nil)
- ((= item (car collection)) t)
- (t (member? item (cdr collection))))))
-
-;; (member? (type member?) '("LMDA" "NLMD"))
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/nth.lisp b/lisp/nth.lisp
deleted file mode 100644
index cd03355..0000000
--- a/lisp/nth.lisp
+++ /dev/null
@@ -1,6 +0,0 @@
-(set! nth (lambda (n l)
- "Return the `n`th member of this list `l`, or `nil` if none."
- (cond ((= nil l) nil)
- ((= n 1) (car l))
- (t (nth (- n 1) (cdr l))))))
-
diff --git a/lisp/scratchpad.lisp b/lisp/scratchpad.lisp
index 4d82164..0474099 100644
--- a/lisp/scratchpad.lisp
+++ b/lisp/scratchpad.lisp
@@ -46,7 +46,3 @@
"This blows up: 10^37, which is a three cell bignum."
(inspect (set! final (+ z z z z z z z z z z)))
-
-(mapcar (lambda (n) (list (:name (meta n)) (:documentation (meta n)))) (keys (oblist)))
-
-((keys "`(keys store)`: Return a list of all keys in this `store`.") (set nil) (let nil) (quote nil) (nil nil) (read nil) (nil nil) (nil nil) (oblist "`(oblist)`: Return the current symbol bindings, as a map.") (cons "`(cons a b)`: Return a cons cell whose `car` is `a` and whose `cdr` is `b`.") (source nil) (cond nil) (nil nil) (eq? "`(eq? args...)`: Return `t` if all args are the exact same object, else `nil`.") (close "`(close stream)`: If `stream` is a stream, close that stream.") (meta "`(meta symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.") (nil nil) (not "`(not arg)`: Return`t` only if `arg` is `nil`, else `nil`.") (mapcar "`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.") (negative? "`(negative? n)`: Return `t` if `n` is a negative number, else `nil`.") (open "`(open url read?)`: Open a stream to this `url`. If `read` is present and is non-nil, open it for reading, else writing.") (subtract nil) (nil nil) (nil nil) (nil nil) (or "`(or args...)`: Return a logical `or` of all the arguments and return `t` if any is truthy, else `nil`.") (nil nil) (and "`(and args...)`: Return a logical `and` of all the arguments and return `t` only if all are truthy, else `nil`.") (count "`(count s)`: Return the number of items in the sequence `s`.") (eval nil) (nλ nil) (nil nil) (nil nil) (nil nil) (nil nil) (cdr "`(cdr arg)`: If `arg` is a sequence, return the remainder of that sequence with the first item removed.") (equal? "`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.") (set! nil) (nil nil) (nil nil) (reverse nil) (slurp nil) (try nil) (assoc "`(assoc key store)`: Return the value associated with this `key` in this `store`.") (nil nil) (add "`(+ args...)`: If `args` are all numbers, return the sum of those numbers.") (list "`(list args...): Return a list of these `args`.") (time nil) (car "`(car arg)`: If `arg` is a sequence, return the item which is the head of that sequence.") (nil nil) (nil nil) (nil nil) (absolute "`(absolute arg)`: If `arg` is a number, return the absolute value of that number, else `nil`.") (append "`(append args...)`: If args are all collections, return the concatenation of those collections.") (apply "`(apply f args)`: If `f` is usable as a function, and `args` is a collection, apply `f` to `args` and return the value.") (divide "`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.") (exception "`(exception message)`: Return (throw) an exception with this `message`.") (get-hash "`(get-hash arg)`: returns the natural number hash value of `arg`.") (hashmap "`(hashmap n-buckets hashfn store acl)`: Return a new hashmap, with `n-buckets` buckets and this `hashfn`, containing the content of this `store`.") (inspect "`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.") (metadata "`(metadata symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.") (multiply "`(* args...)` Multiply these `args`, all of which should be numbers.") (print "`(print object stream)`: Print `object` to `stream`, if specified, else to `*out*`.") (put! nil) (put-all! nil) (ratio->real "`(ratio->real r)`: If `r` is a rational number, return the real number equivalent.") (read-char nil) (repl nil) (throw nil) (type nil) (+ "`(+ args...)`: If `args` are all numbers, return the sum of those numbers.") (* nil) (- nil) (/ nil) (= "`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.") (lambda nil) (λ nil) (nlambda nil) (progn nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil) (nil nil))
diff --git a/lisp/slurp.lisp b/lisp/slurp.lisp
index 2223bbd..e927bcb 100644
--- a/lisp/slurp.lisp
+++ b/lisp/slurp.lisp
@@ -1 +1 @@
-(slurp (open "http://www.journeyman.cc/"))
+(slurp (set! f (open "http://www.journeyman.cc/")))
diff --git a/lisp/types.lisp b/lisp/types.lisp
index e5976ff..7f7bf8c 100644
--- a/lisp/types.lisp
+++ b/lisp/types.lisp
@@ -1,17 +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") ) )
+(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/mad-software.md b/notes/mad-software.md
index 73ab807..bbe8092 100644
--- a/notes/mad-software.md
+++ b/notes/mad-software.md
@@ -6,9 +6,9 @@ I have blogged a lot in the past about madness and about software, but I don't t
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 wo
-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 helprks.
-s subdue the chaos in my mind.
+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:
diff --git a/post-scarcity.cbp b/post-scarcity.cbp
new file mode 100644
index 0000000..a1f42e0
--- /dev/null
+++ b/post-scarcity.cbp
@@ -0,0 +1,157 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/post-scarcity.cscope_file_list b/post-scarcity.cscope_file_list
new file mode 100644
index 0000000..6fbf5ec
--- /dev/null
+++ b/post-scarcity.cscope_file_list
@@ -0,0 +1,58 @@
+"/home/simon/workspace/post-scarcity/utils_src/readprintwc/readprintwc.c"
+"/home/simon/workspace/post-scarcity/src/memory/vectorspace.c"
+"/home/simon/workspace/post-scarcity/src/arith/peano.c"
+"/home/simon/workspace/post-scarcity/src/init.c"
+"/home/simon/workspace/post-scarcity/src/utils.h"
+"/home/simon/workspace/post-scarcity/src/ops/intern.h"
+"/home/simon/workspace/post-scarcity/src/arith/ratio.h"
+"/home/simon/workspace/post-scarcity/src/io/io.c"
+"/home/simon/workspace/post-scarcity/src/memory/conspage.h"
+"/home/simon/workspace/post-scarcity/src/time/psse_time.h"
+"/home/simon/workspace/post-scarcity/src/memory/cursor.h"
+"/home/simon/workspace/post-scarcity/src/memory/dump.h"
+"/home/simon/workspace/post-scarcity/src/ops/intern.c"
+"/home/simon/workspace/post-scarcity/src/memory/lookup3.c"
+"/home/simon/workspace/post-scarcity/src/io/fopen.h"
+"/home/simon/workspace/post-scarcity/src/version.h"
+"/home/simon/workspace/post-scarcity/src/memory/consspaceobject.h"
+"/home/simon/workspace/post-scarcity/src/ops/meta.h"
+"/home/simon/workspace/post-scarcity/src/arith/real.c"
+"/home/simon/workspace/post-scarcity/src/ops/loop.c"
+"/home/simon/workspace/post-scarcity/src/arith/integer.h"
+"/home/simon/workspace/post-scarcity/src/time/psse_time.c"
+"/home/simon/workspace/post-scarcity/src/memory/vectorspace.h"
+"/home/simon/workspace/post-scarcity/src/memory/hashmap.c"
+"/home/simon/workspace/post-scarcity/src/io/read.c"
+"/home/simon/workspace/post-scarcity/src/ops/lispops.h"
+"/home/simon/workspace/post-scarcity/src/ops/loop.h"
+"/home/simon/workspace/post-scarcity/src/memory/stack.h"
+"/home/simon/workspace/post-scarcity/utils_src/tagvalcalc/tagvalcalc.c"
+"/home/simon/workspace/post-scarcity/src/debug.c"
+"/home/simon/workspace/post-scarcity/src/io/read.h"
+"/home/simon/workspace/post-scarcity/src/ops/meta.c"
+"/home/simon/workspace/post-scarcity/src/memory/dump.c"
+"/home/simon/workspace/post-scarcity/src/repl.c"
+"/home/simon/workspace/post-scarcity/src/io/print.c"
+"/home/simon/workspace/post-scarcity/src/memory/hashmap.h"
+"/home/simon/workspace/post-scarcity/src/utils.c"
+"/home/simon/workspace/post-scarcity/src/io/io.h"
+"/home/simon/workspace/post-scarcity/src/memory/stack.c"
+"/home/simon/workspace/post-scarcity/utils_src/debugflags/debugflags.c"
+"/home/simon/workspace/post-scarcity/src/memory/consspaceobject.c"
+"/home/simon/workspace/post-scarcity/src/memory/conspage.c"
+"/home/simon/workspace/post-scarcity/src/memory/cursor.c"
+"/home/simon/workspace/post-scarcity/src/arith/ratio.c"
+"/home/simon/workspace/post-scarcity/Makefile"
+"/home/simon/workspace/post-scarcity/src/arith/peano.h"
+"/home/simon/workspace/post-scarcity/src/memory/lookup3.h"
+"/home/simon/workspace/post-scarcity/src/arith/real.h"
+"/home/simon/workspace/post-scarcity/src/ops/equal.c"
+"/home/simon/workspace/post-scarcity/src/ops/lispops.c"
+"/home/simon/workspace/post-scarcity/src/authorise.h"
+"/home/simon/workspace/post-scarcity/src/io/print.h"
+"/home/simon/workspace/post-scarcity/src/authorise.c"
+"/home/simon/workspace/post-scarcity/src/debug.h"
+"/home/simon/workspace/post-scarcity/src/arith/integer.c"
+"/home/simon/workspace/post-scarcity/src/ops/equal.h"
+"/home/simon/workspace/post-scarcity/src/repl.h"
+"/home/simon/workspace/post-scarcity/src/io/fopen.c"
diff --git a/post-scarcity.layout b/post-scarcity.layout
new file mode 100644
index 0000000..98bd2b3
--- /dev/null
+++ b/post-scarcity.layout
@@ -0,0 +1,15 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/arith/integer.c b/src/arith/integer.c
index 3688ff5..63f7dd2 100644
--- a/src/arith/integer.c
+++ b/src/arith/integer.c
@@ -12,20 +12,18 @@
#include
#include
#include
-#include
/*
* wide characters
*/
#include
#include
-#include "arith/integer.h"
-#include "arith/peano.h"
-#include "debug.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
+#include "debug.h"
#include "ops/equal.h"
#include "ops/lispops.h"
+#include "arith/peano.h"
/**
* hexadecimal digits for printing numbers.
@@ -34,52 +32,9 @@ const char *hex_digits = "0123456789ABCDEF";
/*
* Doctrine from here on in is that ALL integers are bignums, it's just
- * that integers less than 61 bits are bignums of one cell only.
- * that integers less than 61 bits are bignums of one cell only.
- * TODO: why do I not have confidence to make this 64 bits?
+ * that integers less than 65 bits are bignums of one cell only.
*/
- /*
- * A small_int_cache array of pointers to the integers 0...23,
- * used only by functions `acquire_integer(int64) => cons_pointer` and
- * `release_integer(cons_pointer) => NULL` which, if the value desired is
- * in the cache, supplies it from the cache, and, otherwise, calls
- * make_integer() and dec_ref() respectively.
- */
-
-#define SMALL_INT_LIMIT 24
-bool small_int_cache_initialised = false;
-struct cons_pointer small_int_cache[SMALL_INT_LIMIT];
-
- /**
- * 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: expected to 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 : ( INT_CELL_BASE );
-
- __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;
-}
-
-
/**
* Allocate an integer cell representing this `value` and return a cons_pointer to it.
* @param value an integer value;
@@ -90,13 +45,6 @@ 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 )
- && ( pointer2cell( more ).payload.integer.value < 0 ) ) {
- printf( "WARNING: negative value %" PRId64
- " passed as `more` to `make_integer`\n",
- pointer2cell( more ).payload.integer.value );
- }
-
if ( integerp( more ) || nilp( more ) ) {
result = allocate_cell( INTEGERTV );
struct cons_space_object *cell = &pointer2cell( result );
@@ -110,79 +58,39 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) {
}
/**
- * @brief Supply small valued integers from the small integer cache, if available.
+ * Low level integer arithmetic, do not use elsewhere.
*
- * The pattern here is intended to be that, at least within this file, instead of
- * calling make_integer when an integer is required and dec_ref when it's no longer
- * required, we call acquire_integer and release_integer respectively, in order to
- * reduce allocation churn.
- *
- * In the initial implementation, acquire_integer supplies the integer from the
- * small integer cache if available, else calls make_integer. Later, more
- * sophisticated caching of integers which are currently in play may be enabled.
- *
- * @param value the value of the integer desired.
- * @param more if this value is a bignum, the rest (less significant bits) of the
- * value.
- * @return struct cons_pointer a pointer to the integer acquired.
+ * @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
*/
-struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more ) {
- struct cons_pointer result;
+__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;
- if ( !nilp( more ) || value < 0 || value >= SMALL_INT_LIMIT ) {
- debug_print
- ( L"acquire_integer passing to make_integer (outside small int range)\n",
- DEBUG_ALLOC );
- result = make_integer( value, more );
- } else {
- if ( !small_int_cache_initialised ) {
- for ( int64_t i = 0; i < SMALL_INT_LIMIT; i++ ) {
- small_int_cache[i] = make_integer( i, NIL );
- pointer2cell( small_int_cache[i] ).count = MAXREFERENCE; // lock it in so it can't be GC'd
- }
- small_int_cache_initialised = true;
- debug_print( L"small_int_cache initialised.\n", DEBUG_ALLOC );
- }
+ 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 );
- debug_printf( DEBUG_ALLOC, L"acquire_integer: returning %" PRId64 "\n",
- value );
- result = small_int_cache[value];
- }
return result;
}
/**
- * @brief if the value of p is less than the size of the small integer cache
- * (and thus it was presumably supplied from there), suppress dec_ref.
- *
- * **NOTE THAT** at this stage it's still safe to dec_ref an arbitrary integer,
- * because those in the cache are locked and can't be dec_refed.
- *
- * @param p a pointer, expected to be to an integer.
- */
-void release_integer( struct cons_pointer p ) {
- struct cons_space_object o = pointer2cell( p );
- if ( !integerp( p ) || // what I've been passed isn't an integer;
- !nilp( o.payload.integer.more ) || // or it's a bignum;
- o.payload.integer.value >= SMALL_INT_LIMIT || // or it's bigger than the small int cache limit;
- !eq( p, small_int_cache[o.payload.integer.value] ) // or it's simply not the copy in the cache...
- ) {
- dec_ref( p );
- } else {
- debug_printf( DEBUG_ALLOC, L"release_integer: releasing %" PRId64 "\n",
- o.payload.integer.value );
- }
-}
-
-
-/**
- * @brief Overwrite the value field of the integer indicated by `new` with
+ * Overwrite the value field of the integer indicated by `new` with
* the least significant INTEGER_BITS bits of `val`, and return the
- * more significant bits (if any) right-shifted by INTEGER_BITS places.
- *
- * Destructive, primitive, DO NOT USE in any context except primitive
- * operations on integers. The value passed as `new` MUST be constructed
- * with `make_integer`, NOT acquired with `acquire_integer`.
+ * more significant bits (if any) right-shifted by INTEGER_BITS 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,
@@ -193,30 +101,50 @@ void release_integer( struct cons_pointer p ) {
__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 % INT_CELL_BASE;
+ carry = val >> INTEGER_BITS;
debug_printf( DEBUG_ARITH,
L"int128_to_integer: 64 bit overflow; setting carry to %ld\n",
( int64_t ) carry );
- val /= INT_CELL_BASE;
+ val &= MAX_INTEGER;
}
struct cons_space_object *newc = &pointer2cell( new );
- newc->payload.integer.value = ( int64_t ) val;
+ newc->payload.integer.value = val;
if ( integerp( less_significant ) ) {
struct cons_space_object *lsc = &pointer2cell( less_significant );
- // inc_ref( new );
+ 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 >> INTEGER_BITS;
+ }
+
+ } 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.
@@ -226,29 +154,37 @@ struct cons_pointer add_integers( struct cons_pointer a,
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;
- while ( integerp( a ) || integerp( 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;
+ 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 );
- 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 );
+ 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 );
- if ( carry == 0 && rv >= 0 && rv < SMALL_INT_LIMIT && is_first_cell ) {
- result =
- acquire_integer( ( int64_t ) ( rv & MAX_INTEGER ), NIL );
- break;
- } else {
struct cons_pointer new = make_integer( 0, NIL );
carry = int128_to_integer( rv, cursor, new );
cursor = new;
@@ -262,7 +198,7 @@ struct cons_pointer add_integers( struct cons_pointer a,
is_first_cell = false;
}
}
-
+
debug_print( L"add_integers returning: ", DEBUG_ARITH );
debug_print_object( result, DEBUG_ARITH );
debug_println( DEBUG_ARITH );
@@ -270,45 +206,32 @@ struct cons_pointer add_integers( struct cons_pointer a,
return result;
}
-// TODO: I have really no idea what I was trying to do here, or why it could possibly be a good idea.
struct cons_pointer base_partial( int depth ) {
struct cons_pointer result = NIL;
- debug_printf( DEBUG_ARITH, L"base_partial: depth = %d\n", depth );
-
for ( int i = 0; i < depth; i++ ) {
- result = acquire_integer( 0, result );
+ result = make_integer( 0, result );
}
return result;
}
/**
- * @brief Return a copy of this `partial` with this `digit` appended.
- *
- * @param partial the more significant bits of a possible bignum.
- * @param digit the less significant bits of that possible bignum. NOTE: the
- * name `digit` is technically correct but possibly misleading, because the
- * numbering system here is base INT_CELL_BASE, currently x0fffffffffffffffL
+ * destructively modify this `partial` by appending this `digit`.
*/
-struct cons_pointer append_cell( struct cons_pointer partial,
- struct cons_pointer digit ) {
- struct cons_space_object cell = pointer2cell( partial );
- // TODO: I should recursively copy the whole bignum chain, because
- // we're still destructively modifying the end of it.
- struct cons_pointer c = make_integer( cell.payload.integer.value,
- cell.payload.integer.more );
+struct cons_pointer append_digit( struct cons_pointer partial,
+ struct cons_pointer digit ) {
+ struct cons_pointer c = partial;
struct cons_pointer result = partial;
if ( nilp( partial ) ) {
result = digit;
} else {
- // find the last digit in the chain...
while ( !nilp( pointer2cell( c ).payload.integer.more ) ) {
c = pointer2cell( c ).payload.integer.more;
}
- ( pointer2cell( c ) ).payload.integer.more = digit;
+ ( &pointer2cell( c ) )->payload.integer.more = digit;
}
return result;
}
@@ -328,7 +251,7 @@ struct cons_pointer append_cell( struct cons_pointer partial,
*/
struct cons_pointer multiply_integers( struct cons_pointer a,
struct cons_pointer b ) {
- struct cons_pointer result = acquire_integer( 0, NIL );
+ struct cons_pointer result = make_integer( 0, NIL );
bool neg = is_negative( a ) != is_negative( b );
bool is_first_b = true;
int i = 0;
@@ -368,20 +291,17 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
/* if xj exceeds one digit, break it into the digit dj and
* the carry */
- carry = xj >> INTEGER_BIT_SHIFT;
- struct cons_pointer dj =
- acquire_integer( xj & MAX_INTEGER, NIL );
+ carry = xj >> INTEGER_BITS;
+ struct cons_pointer dj = make_integer( xj & MAX_INTEGER, NIL );
- replace_integer_p( ri, append_cell( ri, dj ) );
- // struct cons_pointer new_ri = append_cell( ri, dj );
- // release_integer( ri);
- // ri = new_ri;
+ /* destructively modify ri by appending dj */
+ ri = append_digit( ri, dj );
} /* end for bj */
- /* if carry is not equal to zero, append it as a final cell
+ /* if carry is not equal to zero, append it as a final digit
* to ri */
if ( carry != 0 ) {
- replace_integer_i( ri, carry )
+ ri = append_digit( ri, make_integer( carry, NIL ) );
}
/* add ri to result */
@@ -401,29 +321,18 @@ struct cons_pointer multiply_integers( struct cons_pointer a,
}
/**
- * don't use; private to integer_to_string, and somewhat dodgy.
+ * 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] );
- debug_printf( DEBUG_IO,
- L"integer_to_string_add_digit: digit is %d, digits is %d; returning: ",
- digit, digits );
- struct cons_pointer r =
- ( digits % 3 == 0 ) ? make_string( L',', make_string( character,
- tail ) ) :
+ return ( digits % 3 == 0 ) ?
+ make_string( L',', make_string( character,
+ tail ) ) :
make_string( character, tail );
-
- debug_print_object( r, DEBUG_IO );
- debug_println( DEBUG_IO );
-
- return r;
}
/**
- * @brief return a string representation of this integer, which may be a
- * bignum.
- *
* 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.
@@ -433,9 +342,6 @@ struct cons_pointer integer_to_string_add_digit( int digit, int digits,
* 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.
- *
- * @param int_pointer cons_pointer to the integer to print,
- * @param base the base to print it in.
*/
struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
int base ) {
@@ -456,8 +362,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer,
while ( accumulator > 0 || !nilp( next ) ) {
if ( accumulator < MAX_INTEGER && !nilp( next ) ) {
accumulator +=
- ( pointer2cell( next ).payload.integer.value %
- INT_CELL_BASE );
+ ( pointer2cell( next ).payload.integer.value << INTEGER_BITS );
next = pointer2cell( next ).payload.integer.more;
}
int offset = ( int ) ( accumulator % base );
@@ -507,3 +412,21 @@ bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ) {
return result;
}
+
+/**
+ * true if `a` is an integer, and `b` is a real number whose value is the
+ * value of that integer.
+ */
+bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) {
+ bool result = false;
+
+ if ( integerp( a ) && realp( b ) ) {
+ long double bv = pointer2cell( b ).payload.real.value;
+
+ if ( floor( bv ) == bv ) {
+ result = pointer2cell( a ).payload.integer.value == ( int64_t ) bv;
+ }
+ }
+
+ return result;
+}
diff --git a/src/arith/integer.h b/src/arith/integer.h
index e08549f..09a7a83 100644
--- a/src/arith/integer.h
+++ b/src/arith/integer.h
@@ -13,18 +13,9 @@
#include
#include
-#include "memory/consspaceobject.h"
-
-
-#define replace_integer_i(p,i) {struct cons_pointer __p = acquire_integer(i,NIL); release_integer(p); p = __p;}
-#define replace_integer_p(p,q) {struct cons_pointer __p = p; release_integer( p); p = q;}
struct cons_pointer make_integer( int64_t value, struct cons_pointer more );
-struct cons_pointer acquire_integer( int64_t value, struct cons_pointer more );
-
-void release_integer( struct cons_pointer p );
-
struct cons_pointer add_integers( struct cons_pointer a,
struct cons_pointer b );
diff --git a/src/arith/peano.c b/src/arith/peano.c
index 9a1b478..ae23a00 100644
--- a/src/arith/peano.c
+++ b/src/arith/peano.c
@@ -64,35 +64,6 @@ bool zerop( struct cons_pointer arg ) {
return result;
}
-// TODO: think about
-// bool greaterp( struct cons_pointer arg_1, struct cons_pointer arg_2) {
-// bool result = false;
-// struct cons_space_object * cell_1 = & pointer2cell( arg_1 );
-// struct cons_space_object * cell_2 = & pointer2cell( arg_2 );
-
-// if (cell_1->tag.value == cell_2->tag.value) {
-
-// switch ( cell_1->tag.value ) {
-// case INTEGERTV:{
-// if ( nilp(cell_1->payload.integer.more) && nilp( cell_2->payload.integer.more)) {
-// result = cell_1->payload.integer.value > cell_2->payload.integer.value;
-// }
-// // else deal with comparing bignums...
-// }
-// break;
-// case RATIOTV:
-// result = lisp_ratio_to_real( cell_1) > ratio_to_real( cell_2);
-// break;
-// case REALTV:
-// result = ( cell.payload.real.value == 0 );
-// break;
-// }
-// }
-
-// return result;
-
-// }
-
/**
* does this `arg` point to a negative number?
*/
@@ -115,36 +86,24 @@ bool is_negative( struct cons_pointer arg ) {
return result;
}
-/**
- * @brief if `arg` is a number, return the absolute value of that number, else
- * `NIL`
- *
- * @param arg a cons space object, probably a number.
- * @return struct cons_pointer
- */
struct cons_pointer absolute( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
struct cons_space_object cell = pointer2cell( arg );
- if ( numberp( arg ) ) {
- if ( is_negative( arg ) ) {
- switch ( cell.tag.value ) {
- case INTEGERTV:
- result =
- make_integer( llabs( cell.payload.integer.value ),
- cell.payload.integer.more );
- break;
- case RATIOTV:
- result =
- make_ratio( absolute( cell.payload.ratio.dividend ),
- cell.payload.ratio.divisor, false );
- break;
- case REALTV:
- result = make_real( 0 - cell.payload.real.value );
- break;
- }
- } else {
- result = arg;
+ if ( is_negative( arg ) ) {
+ switch ( cell.tag.value ) {
+ case INTEGERTV:
+ result =
+ make_integer( llabs( cell.payload.integer.value ),
+ cell.payload.integer.more );
+ break;
+ case RATIOTV:
+ result = make_ratio( absolute( cell.payload.ratio.dividend ),
+ cell.payload.ratio.divisor );
+ break;
+ case REALTV:
+ result = make_real( 0 - cell.payload.real.value );
+ break;
}
}
@@ -296,11 +255,9 @@ struct cons_pointer add_2( struct stack_frame *frame,
to_long_double( arg2 ) );
break;
default:
- result =
- throw_exception( c_string_to_lisp_symbol( L"+" ),
- c_string_to_lisp_string
- ( L"Cannot add: not a number" ),
- frame_pointer );
+ result = throw_exception( c_string_to_lisp_string
+ ( L"Cannot add: not a number" ),
+ frame_pointer );
break;
}
break;
@@ -321,11 +278,9 @@ struct cons_pointer add_2( struct stack_frame *frame,
to_long_double( arg2 ) );
break;
default:
- result =
- throw_exception( c_string_to_lisp_symbol( L"+" ),
- c_string_to_lisp_string
- ( L"Cannot add: not a number" ),
- frame_pointer );
+ result = throw_exception( c_string_to_lisp_string
+ ( L"Cannot add: not a number" ),
+ frame_pointer );
break;
}
break;
@@ -336,8 +291,7 @@ struct cons_pointer add_2( struct stack_frame *frame,
break;
default:
result = exceptionp( arg2 ) ? arg2 :
- throw_exception( c_string_to_lisp_symbol( L"+" ),
- c_string_to_lisp_string
+ throw_exception( c_string_to_lisp_string
( L"Cannot add: not a number" ),
frame_pointer );
}
@@ -433,8 +387,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break;
default:
result =
- throw_exception( c_string_to_lisp_symbol( L"*" ),
- make_cons
+ throw_exception( make_cons
( c_string_to_lisp_string
( L"Cannot multiply: argument 2 is not a number: " ),
c_type( arg2 ) ),
@@ -460,8 +413,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
break;
default:
result =
- throw_exception( c_string_to_lisp_symbol( L"*" ),
- make_cons
+ throw_exception( make_cons
( c_string_to_lisp_string
( L"Cannot multiply: argument 2 is not a number" ),
c_type( arg2 ) ),
@@ -474,8 +426,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame,
to_long_double( arg2 ) );
break;
default:
- result = throw_exception( c_string_to_lisp_symbol( L"*" ),
- make_cons( c_string_to_lisp_string
+ result = throw_exception( make_cons( c_string_to_lisp_string
( L"Cannot multiply: argument 1 is not a number" ),
c_type( arg1 ) ),
frame_pointer );
@@ -553,7 +504,7 @@ struct cons_pointer negative( struct cons_pointer arg ) {
break;
case RATIOTV:
result = make_ratio( negative( cell.payload.ratio.dividend ),
- cell.payload.ratio.divisor, false );
+ cell.payload.ratio.divisor );
break;
case REALTV:
result = make_real( 0 - to_long_double( arg ) );
@@ -615,8 +566,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
case RATIOTV:{
struct cons_pointer tmp = make_ratio( arg1,
make_integer( 1,
- NIL ),
- false );
+ NIL ) );
inc_ref( tmp );
result = subtract_ratio_ratio( tmp, arg2 );
dec_ref( tmp );
@@ -628,8 +578,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
to_long_double( arg2 ) );
break;
default:
- result = throw_exception( c_string_to_lisp_symbol( L"-" ),
- c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
@@ -643,8 +592,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
case INTEGERTV:{
struct cons_pointer tmp = make_ratio( arg2,
make_integer( 1,
- NIL ),
- false );
+ NIL ) );
inc_ref( tmp );
result = subtract_ratio_ratio( arg1, tmp );
dec_ref( tmp );
@@ -659,8 +607,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
to_long_double( arg2 ) );
break;
default:
- result = throw_exception( c_string_to_lisp_symbol( L"-" ),
- c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
@@ -671,8 +618,7 @@ struct cons_pointer subtract_2( struct stack_frame *frame,
make_real( to_long_double( arg1 ) - to_long_double( arg2 ) );
break;
default:
- result = throw_exception( c_string_to_lisp_symbol( L"-" ),
- c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( L"Cannot subtract: not a number" ),
frame_pointer );
break;
@@ -724,14 +670,21 @@ struct cons_pointer lisp_divide( struct
result = frame->arg[1];
break;
case INTEGERTV:{
- result =
- make_ratio( frame->arg[0], frame->arg[1], true );
+ struct cons_pointer unsimplified =
+ make_ratio( frame->arg[0],
+ frame->arg[1] );
+ /* OK, if result may be unsimplified, we should not inc_ref it
+ * - but if not, we should dec_ref it. */
+ result = simplify_ratio( unsimplified );
+ if ( !eq( unsimplified, result ) ) {
+ dec_ref( unsimplified );
+ }
}
break;
case RATIOTV:{
struct cons_pointer one = make_integer( 1, NIL );
struct cons_pointer ratio =
- make_ratio( frame->arg[0], one, false );
+ make_ratio( frame->arg[0], one );
inc_ref( ratio );
result = divide_ratio_ratio( ratio, frame->arg[1] );
dec_ref( ratio );
@@ -743,8 +696,7 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) );
break;
default:
- result = throw_exception( c_string_to_lisp_symbol( L"/" ),
- c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
@@ -757,8 +709,10 @@ struct cons_pointer lisp_divide( struct
break;
case INTEGERTV:{
struct cons_pointer one = make_integer( 1, NIL );
+ inc_ref( one );
struct cons_pointer ratio =
- make_ratio( frame->arg[1], one, false );
+ make_ratio( frame->arg[1], one );
+ inc_ref( ratio );
result = divide_ratio_ratio( frame->arg[0], ratio );
dec_ref( ratio );
dec_ref( one );
@@ -774,8 +728,7 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) );
break;
default:
- result = throw_exception( c_string_to_lisp_symbol( L"/" ),
- c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
@@ -787,8 +740,7 @@ struct cons_pointer lisp_divide( struct
to_long_double( frame->arg[1] ) );
break;
default:
- result = throw_exception( c_string_to_lisp_symbol( L"/" ),
- c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( L"Cannot divide: not a number" ),
frame_pointer );
break;
@@ -796,30 +748,3 @@ struct cons_pointer lisp_divide( struct
return result;
}
-
-/**
- * @brief Function: return a real (approcimately) equal in value to the ratio
- * which is the first argument.
- *
- * @param frame
- * @param frame_pointer
- * @param env
- * @return struct cons_pointer a pointer to a real
- */
-// struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
-// struct cons_pointer env )
-struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame,
- struct cons_pointer frame_pointer,
- struct cons_pointer env ) {
- struct cons_pointer result = NIL;
- struct cons_pointer rat = frame->arg[0];
-
- debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH );
- debug_print_object( rat, DEBUG_ARITH );
-
- if ( ratiop( rat ) ) {
- result = make_real( c_ratio_to_ld( rat ) );
- } // TODO: else throw an exception?
-
- return result;
-}
diff --git a/src/arith/peano.h b/src/arith/peano.h
index c85a9d8..a7d63b3 100644
--- a/src/arith/peano.h
+++ b/src/arith/peano.h
@@ -7,42 +7,20 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
+#include "consspaceobject.h"
#ifndef PEANO_H
#define PEANO_H
-#include "memory/consspaceobject.h"
-
/**
- * The maximum value we will allow in an integer cell: one less than 2^60:
- * (let ((s (make-string-output-stream)))
- * (format s "0x0~XL" (- (expt 2 60) 1))
- * (string-downcase (get-output-stream-string s)))
- * "0x0fffffffffffffffl"
- *
- * So left shifting and right shifting by 60 bits is correct.
+ * The maximum value we will allow in an integer cell.
*/
-#define MAX_INTEGER ((__int128_t)0x0fffffffffffffffL)
-#define INT_CELL_BASE ((__int128_t)MAX_INTEGER + 1) // ((__int128_t)0x1000000000000000L)
-
+#define MAX_INTEGER ((__int128_t)0x0fffffffffffffffL)
/**
* @brief Number of value bits in an integer cell
*
*/
-#define INTEGER_BIT_SHIFT (60)
-
-/**
- * @brief return `true` if arg is `nil`, else `false`.
- *
- * Note that this doesn't really belong in `peano.h`, but after code cleanup it
- * was the last thing remaining in either `boolean.c` or `boolean.h`, and it
- * wasn't worth keeping two files around for one one-line macro.
- *
- * @param arg
- * @return true if the sole argument is `nil`.
- * @return false otherwise.
- */
-#define truthy(arg)(!nilp(arg))
+#define INTEGER_BITS 60
bool zerop( struct cons_pointer arg );
@@ -88,8 +66,4 @@ struct cons_pointer
lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
-struct cons_pointer lisp_ratio_to_real( 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 82f9138..5135d6b 100644
--- a/src/arith/ratio.c
+++ b/src/arith/ratio.c
@@ -11,21 +11,19 @@
#include
#include
-#include "arith/integer.h"
-#include "arith/peano.h"
-#include "arith/ratio.h"
-#include "arith/real.h"
-#include "debug.h"
-#include "io/print.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
-#include "memory/stack.h"
+#include "debug.h"
#include "ops/equal.h"
+#include "arith/integer.h"
#include "ops/lispops.h"
+#include "arith/peano.h"
+#include "io/print.h"
+#include "arith/ratio.h"
/**
- * @brief return, as an int64_t, the greatest common divisor of `m` and `n`,
+ * return, as a int64_t, the greatest common divisor of `m` and `n`,
*/
int64_t greatest_common_divisor( int64_t m, int64_t n ) {
int o;
@@ -39,7 +37,7 @@ int64_t greatest_common_divisor( int64_t m, int64_t n ) {
}
/**
- * @brief return, as an int64_t, the least common multiple of `m` and `n`,
+ * return, as a int64_t, the least common multiple of `m` and `n`,
*/
int64_t least_common_multiple( int64_t m, int64_t n ) {
return m / greatest_common_divisor( m, n ) * n;
@@ -47,38 +45,31 @@ int64_t least_common_multiple( int64_t m, int64_t n ) {
struct cons_pointer simplify_ratio( struct cons_pointer pointer ) {
struct cons_pointer result = pointer;
+ struct cons_space_object cell = pointer2cell( pointer );
+ struct cons_space_object dividend =
+ pointer2cell( cell.payload.ratio.dividend );
+ struct cons_space_object divisor =
+ pointer2cell( cell.payload.ratio.divisor );
- if ( ratiop( pointer ) ) {
- struct cons_space_object cell = pointer2cell( pointer );
- struct cons_space_object dividend =
- pointer2cell( cell.payload.ratio.dividend );
- struct cons_space_object divisor =
- pointer2cell( cell.payload.ratio.divisor );
-
- if ( divisor.payload.integer.value == 1 ) {
- result = pointer2cell( pointer ).payload.ratio.dividend;
- } else {
+ if ( divisor.payload.integer.value == 1 ) {
+ result = pointer2cell( pointer ).payload.ratio.dividend;
+ } else {
+ if ( ratiop( pointer ) ) {
int64_t ddrv = dividend.payload.integer.value,
drrv = divisor.payload.integer.value,
gcd = greatest_common_divisor( ddrv, drrv );
if ( gcd > 1 ) {
if ( drrv / gcd == 1 ) {
- result =
- acquire_integer( ( int64_t ) ( ddrv / gcd ), NIL );
+ result = make_integer( ddrv / gcd, NIL );
} else {
- debug_printf( DEBUG_ARITH,
- L"simplify_ratio: %ld/%ld => %ld/%ld\n",
- ddrv, drrv, ddrv / gcd, drrv / gcd );
result =
- make_ratio( acquire_integer( ddrv / gcd, NIL ),
- acquire_integer( drrv / gcd, NIL ),
- false );
+ make_ratio( make_integer( ddrv / gcd, NIL ),
+ make_integer( drrv / gcd, NIL ) );
}
}
}
}
- // TODO: else throw exception?
return result;
@@ -93,40 +84,69 @@ struct cons_pointer simplify_ratio( struct cons_pointer pointer ) {
*/
struct cons_pointer add_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) {
- struct cons_pointer r;
+ struct cons_pointer r, result;
- debug_print( L"\nadd_ratio_ratio: ", DEBUG_ARITH );
+ debug_print( L"add_ratio_ratio( arg1 = ", DEBUG_ARITH );
debug_print_object( arg1, DEBUG_ARITH );
- debug_print( L" + ", DEBUG_ARITH );
+ debug_print( L"; arg2 = ", DEBUG_ARITH );
debug_print_object( arg2, DEBUG_ARITH );
+ debug_print( L")\n", DEBUG_ARITH );
if ( ratiop( arg1 ) && ratiop( arg2 ) ) {
- struct cons_space_object *cell1 = &pointer2cell( arg1 );
- struct cons_space_object *cell2 = &pointer2cell( arg2 );
+ struct cons_space_object cell1 = pointer2cell( arg1 );
+ struct cons_space_object cell2 = pointer2cell( arg2 );
+ int64_t dd1v =
+ pointer2cell( cell1.payload.ratio.dividend ).payload.integer.value,
+ dd2v =
+ pointer2cell( cell2.payload.ratio.dividend ).payload.integer.value,
+ dr1v =
+ pointer2cell( cell1.payload.ratio.divisor ).payload.integer.value,
+ dr2v =
+ pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
+ lcm = least_common_multiple( dr1v, dr2v ),
+ m1 = lcm / dr1v, m2 = lcm / dr2v;
- struct cons_pointer divisor =
- multiply_integers( cell1->payload.ratio.divisor,
- cell2->payload.ratio.divisor );
- struct cons_pointer dividend =
- add_integers( multiply_integers( cell1->payload.ratio.dividend,
- cell2->payload.ratio.divisor ),
- multiply_integers( cell2->payload.ratio.dividend,
- cell1->payload.ratio.divisor ) );
- r = make_ratio( dividend, divisor, true );
+ debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm,
+ m1, m2 );
+
+ if ( dr1v == dr2v ) {
+ r = make_ratio( make_integer( dd1v + dd2v, NIL ),
+ cell1.payload.ratio.divisor );
+ } else {
+ 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( dd1vm, dr1vm ),
+ r2 = make_ratio( dd2vm, dr2vm );
+
+ r = add_ratio_ratio( r1, r2 );
+
+ /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were
+ * never incremented except when making r1 and r2, decrementing
+ * r1 and r2 should be enought to garbage collect them. */
+ dec_ref( r1 );
+ dec_ref( r2 );
+ }
+
+ result = simplify_ratio( r );
+ if ( !eq( r, result ) ) {
+ dec_ref( r );
+ }
} else {
- r = throw_exception( c_string_to_lisp_symbol( L"+" ),
- make_cons( c_string_to_lisp_string
+ result =
+ throw_exception( make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_ratio_ratio" ),
make_cons( arg1,
make_cons( arg2, NIL ) ) ),
NIL );
}
- debug_print( L"add_ratio_ratio => ", DEBUG_ARITH );
- debug_print_object( r, DEBUG_ARITH );
+ debug_print( L" => ", DEBUG_ARITH );
+ debug_print_object( result, DEBUG_ARITH );
debug_print( L"\n", DEBUG_ARITH );
- return r;
+ return result;
}
@@ -140,33 +160,24 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg ) {
struct cons_pointer result;
- debug_print( L"\nadd_integer_ratio: ", DEBUG_ARITH );
- debug_print_object( intarg, DEBUG_ARITH );
- debug_print( L" + ", DEBUG_ARITH );
- debug_print_object( ratarg, DEBUG_ARITH );
-
if ( integerp( intarg ) && ratiop( ratarg ) ) {
- struct cons_pointer one = acquire_integer( 1, NIL ),
- ratio = make_ratio( intarg, one, false );
+ // TODO: not longer works
+ struct cons_pointer one = make_integer( 1, NIL ),
+ ratio = make_ratio( intarg, one );
result = add_ratio_ratio( ratio, ratarg );
- release_integer( one );
+ dec_ref( one );
dec_ref( ratio );
} else {
result =
- throw_exception( c_string_to_lisp_symbol( L"+" ),
- make_cons( c_string_to_lisp_string
+ throw_exception( make_cons( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to add_integer_ratio" ),
make_cons( intarg,
make_cons( ratarg,
NIL ) ) ), NIL );
}
- debug_print( L" => ", DEBUG_ARITH );
- debug_print_object( result, DEBUG_ARITH );
- debug_print( L"\n", DEBUG_ARITH );
-
return result;
}
@@ -178,22 +189,14 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg,
*/
struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) {
- debug_print( L"\ndivide_ratio_ratio: ", DEBUG_ARITH );
- debug_print_object( arg1, DEBUG_ARITH );
- debug_print( L" / ", DEBUG_ARITH );
- debug_print_object( arg2, DEBUG_ARITH );
// TODO: this now has to work if `arg1` is an integer
struct cons_pointer i =
make_ratio( pointer2cell( arg2 ).payload.ratio.divisor,
- pointer2cell( arg2 ).payload.ratio.dividend, false ),
- result = multiply_ratio_ratio( arg1, i );
+ pointer2cell( arg2 ).payload.ratio.dividend ), result =
+ multiply_ratio_ratio( arg1, i );
dec_ref( i );
- debug_print( L" => ", DEBUG_ARITH );
- debug_print_object( result, DEBUG_ARITH );
- debug_print( L"\n", DEBUG_ARITH );
-
return result;
}
@@ -228,24 +231,21 @@ struct cons_pointer multiply_ratio_ratio( struct
pointer2cell( cell2.payload.ratio.divisor ).payload.integer.value,
ddrv = dd1v * dd2v, drrv = dr1v * dr2v;
- struct cons_pointer dividend = acquire_integer( ddrv, NIL );
- struct cons_pointer divisor = acquire_integer( drrv, NIL );
- result = make_ratio( dividend, divisor, true );
+ struct cons_pointer unsimplified =
+ make_ratio( make_integer( ddrv, NIL ),
+ make_integer( drrv, NIL ) );
+ result = simplify_ratio( unsimplified );
- release_integer( dividend );
- release_integer( divisor );
+ if ( !eq( unsimplified, result ) ) {
+ dec_ref( unsimplified );
+ }
} else {
result =
- throw_exception( c_string_to_lisp_symbol( L"*" ),
- c_string_to_lisp_string
+ throw_exception( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ),
NIL );
}
- debug_print( L" => ", DEBUG_ARITH );
- debug_print_object( result, DEBUG_ARITH );
- debug_print( L"\n", DEBUG_ARITH );
-
return result;
}
@@ -259,29 +259,21 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
struct cons_pointer ratarg ) {
struct cons_pointer result;
- debug_print( L"\nmultiply_integer_ratio: ", DEBUG_ARITH );
- debug_print_object( intarg, DEBUG_ARITH );
- debug_print( L" * ", DEBUG_ARITH );
- debug_print_object( ratarg, DEBUG_ARITH );
-
if ( integerp( intarg ) && ratiop( ratarg ) ) {
- struct cons_pointer one = acquire_integer( 1, NIL ),
- ratio = make_ratio( intarg, one, false );
+ // TODO: no longer works; fix
+ struct cons_pointer one = make_integer( 1, NIL ),
+ ratio = make_ratio( intarg, one );
result = multiply_ratio_ratio( ratio, ratarg );
- release_integer( one );
+ dec_ref( one );
+ dec_ref( ratio );
} else {
result =
- throw_exception( c_string_to_lisp_symbol( L"*" ),
- c_string_to_lisp_string
+ throw_exception( c_string_to_lisp_string
( L"Shouldn't happen: bad arg to multiply_integer_ratio" ),
NIL );
}
- debug_print( L" => ", DEBUG_ARITH );
- debug_print_object( result, DEBUG_ARITH );
- debug_print( L"\n", DEBUG_ARITH );
-
return result;
}
@@ -294,11 +286,6 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg,
*/
struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 ) {
- debug_print( L"\nsubtract_ratio_ratio: ", DEBUG_ARITH );
- debug_print_object( arg1, DEBUG_ARITH );
- debug_print( L" * ", DEBUG_ARITH );
- debug_print_object( arg2, DEBUG_ARITH );
-
struct cons_pointer i = negative( arg2 ),
result = add_ratio_ratio( arg1, i );
@@ -315,49 +302,28 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
* @exception if either `dividend` or `divisor` is not an integer.
*/
struct cons_pointer make_ratio( struct cons_pointer dividend,
- struct cons_pointer divisor, bool simplify ) {
- debug_print( L"make_ratio: dividend = ", DEBUG_ALLOC );
- debug_print_object( dividend, DEBUG_ALLOC );
- debug_print( L"; divisor = ", DEBUG_ALLOC );
- debug_print_object( divisor, DEBUG_ALLOC );
- debug_printf( DEBUG_ALLOC, L"; simplify = %d\n", simplify );
-
+ struct cons_pointer divisor ) {
struct cons_pointer result;
if ( integerp( dividend ) && integerp( divisor ) ) {
inc_ref( dividend );
inc_ref( divisor );
- struct cons_pointer unsimplified = allocate_cell( RATIOTV );
- struct cons_space_object *cell = &pointer2cell( unsimplified );
+ result = allocate_cell( RATIOTV );
+ struct cons_space_object *cell = &pointer2cell( result );
cell->payload.ratio.dividend = dividend;
cell->payload.ratio.divisor = divisor;
-
- if ( simplify ) {
- result = simplify_ratio( unsimplified );
- if ( !eq( result, unsimplified ) ) {
- dec_ref( unsimplified );
- }
- } else {
- result = unsimplified;
- }
} else {
result =
- throw_exception( c_string_to_lisp_symbol( L"make_ratio" ),
- c_string_to_lisp_string
+ throw_exception( c_string_to_lisp_string
( L"Dividend and divisor of a ratio must be integers" ),
NIL );
}
- debug_print( L" => ", DEBUG_ALLOC );
- debug_print_object( result, DEBUG_ALLOC );
- debug_println( DEBUG_ALLOC );
+ debug_dump_object( result, DEBUG_ARITH );
return result;
}
/**
- * True if a and be are identical rationals, else false.
- *
- * TODO: we need ways of checking whether rationals are equal
- * to floats and to integers.
+ * True if a and be are identical ratios, else false.
*/
bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ) {
bool result = false;
@@ -374,38 +340,3 @@ bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ) {
return result;
}
-
-/**
- * @brief convert a ratio to an equivalent long double.
- *
- * @param rat a pointer to a ratio.
- * @return long double
- */
-long double c_ratio_to_ld( struct cons_pointer rat ) {
- long double result = NAN;
-
- debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH );
- debug_print_object( rat, DEBUG_ARITH );
-
- if ( ratiop( rat ) ) {
- struct cons_space_object *cell_a = &pointer2cell( rat );
- struct cons_pointer dv = cell_a->payload.ratio.divisor;
- struct cons_space_object *dv_cell = &pointer2cell( dv );
- struct cons_pointer dd = cell_a->payload.ratio.dividend;
- struct cons_space_object *dd_cell = &pointer2cell( dd );
-
- if ( nilp( dv_cell->payload.integer.more )
- && nilp( dd_cell->payload.integer.more ) ) {
- result =
- ( ( long double ) dd_cell->payload.integer.value ) /
- ( ( long double ) dv_cell->payload.integer.value );;
- } else {
- fwprintf( stderr,
- L"real conversion is not yet implemented for bignums rationals." );
- }
- }
-
- debug_printf( DEBUG_ARITH, L"\nc_ratio_to_ld returning %d\n", result );
-
- return result;
-}
diff --git a/src/arith/ratio.h b/src/arith/ratio.h
index 2e39754..9068bfb 100644
--- a/src/arith/ratio.h
+++ b/src/arith/ratio.h
@@ -32,10 +32,8 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1,
struct cons_pointer arg2 );
struct cons_pointer make_ratio( struct cons_pointer dividend,
- struct cons_pointer divisor, bool simplify );
+ struct cons_pointer divisor );
bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b );
-long double c_ratio_to_ld( struct cons_pointer rat );
-
#endif
diff --git a/src/debug.c b/src/debug.c
index 631149d..233e154 100644
--- a/src/debug.c
+++ b/src/debug.c
@@ -1,4 +1,4 @@
-/*
+/**
* debug.c
*
* Better debug log messages.
@@ -25,36 +25,13 @@
#include "io/print.h"
/**
- * @brief the controlling flags for `debug_print`; set in `init.c`, q.v.
- *
- * Interpreted as a set o binary flags. The values are controlled by macros
- * with names 'DEBUG_[A_Z]*' in `debug.h`, q.v.
+ * the controlling flags for `debug_print`; set in `init.c`, q.v.
*/
int verbosity = 0;
/**
- * When debugging, we want to see exceptions as they happen, because they may
- * not make their way back down the stack to whatever is expected to handle
- * them.
- */
-void debug_print_exception( struct cons_pointer ex_ptr ) {
-#ifdef DEBUG
- if ( ( verbosity != 0 ) && exceptionp( ex_ptr ) ) {
- fwide( stderr, 1 );
- fputws( L"EXCEPTION: ", stderr );
-
- URL_FILE *ustderr = file_to_url_file( stderr );
- fwide( stderr, 1 );
- print( ustderr, ex_ptr );
- free( ustderr );
- }
-#endif
-}
-
-/**
- * @brief print this debug `message` to stderr, if `verbosity` matches `level`.
- *
- * `verbosity` is a set of flags, see debug_print.h; so you can
+ * print this debug `message` to stderr, if `verbosity` matches `level`.
+ * `verbosity is a set of flags, see debug_print.h; so you can
* turn debugging on for only one part of the system.
*/
void debug_print( wchar_t *message, int level ) {
@@ -67,11 +44,6 @@ void debug_print( wchar_t *message, int level ) {
}
/**
- * @brief print a 128 bit integer value to stderr, if `verbosity` matches `level`.
- *
- * `verbosity` is a set of flags, see debug_print.h; so you can
- * turn debugging on for only one part of the system.
- *
* stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc
*/
void debug_print_128bit( __int128_t n, int level ) {
@@ -96,9 +68,8 @@ void debug_print_128bit( __int128_t n, int level ) {
}
/**
- * @brief print a line feed to stderr, if `verbosity` matches `level`.
- *
- * `verbosity` is a set of flags, see debug_print.h; so you can
+ * print a line feed to stderr, if `verbosity` matches `level`.
+ * `verbosity is a set of flags, see debug_print.h; so you can
* turn debugging on for only one part of the system.
*/
void debug_println( int level ) {
@@ -112,10 +83,8 @@ void debug_println( int level ) {
/**
- * @brief `wprintf` adapted for the debug logging system.
- *
- * Print to stderr only if `verbosity` matches `level`. All other arguments
- * as for `wprintf`.
+ * `wprintf` adapted for the debug logging system. Print to stderr only
+ * `verbosity` matches `level`. All other arguments as for `wprintf`.
*/
void debug_printf( int level, wchar_t *format, ... ) {
#ifdef DEBUG
@@ -129,10 +98,8 @@ void debug_printf( int level, wchar_t *format, ... ) {
}
/**
- * @brief print the object indicated by this `pointer` to stderr, if `verbosity`
- * matches `level`.
- *
- * `verbosity` is a set of flags, see debug_print.h; so you can
+ * print the object indicated by this `pointer` to stderr, if `verbosity`
+ * matches `level`.`verbosity is a set of flags, see debug_print.h; so you can
* turn debugging on for only one part of the system.
*/
void debug_print_object( struct cons_pointer pointer, int level ) {
@@ -147,10 +114,7 @@ void debug_print_object( struct cons_pointer pointer, int level ) {
}
/**
- * @brief Like `dump_object`, q.v., but protected by the verbosity mechanism.
- *
- * `verbosity` is a set of flags, see debug_print.h; so you can
- * turn debugging on for only one part of the system.
+ * Like `dump_object`, q.v., but protected by the verbosity mechanism.
*/
void debug_dump_object( struct cons_pointer pointer, int level ) {
#ifdef DEBUG
@@ -162,20 +126,3 @@ void debug_dump_object( struct cons_pointer pointer, int level ) {
}
#endif
}
-
-/**
- * Standardise printing of binding trace messages.
- */
-void debug_print_binding( struct cons_pointer key, struct cons_pointer val,
- bool deep, int level ) {
-#ifdef DEBUG
- // wchar_t * depth = (deep ? L"Deep" : L"Shallow");
-
- debug_print( ( deep ? L"Deep" : L"Shallow" ), level );
- debug_print( L" binding `", level );
- debug_print_object( key, level );
- debug_print( L"` to `", level );
- debug_print_object( val, level );
- debug_print( L"`\n", level );
-#endif
-}
diff --git a/src/debug.h b/src/debug.h
index 6c7c8cb..babbaea 100644
--- a/src/debug.h
+++ b/src/debug.h
@@ -1,4 +1,4 @@
-/*
+/**
* debug.h
*
* Better debug log messages.
@@ -8,94 +8,28 @@
*/
#include
-#include
#include
-#include "memory/consspaceobject.h"
-
#ifndef __debug_print_h
#define __debug_print_h
-/**
- * @brief Print messages debugging memory allocation.
- *
- * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
- */
#define DEBUG_ALLOC 1
-
-/**
- * @brief Print messages debugging arithmetic operations.
- *
- * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
- */
#define DEBUG_ARITH 2
-
-/**
- * @brief Print messages debugging symbol binding.
- *
- * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
- */
#define DEBUG_BIND 4
-
-/**
- * @brief Print messages debugging bootstrapping and teardown.
- *
- * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
- */
#define DEBUG_BOOTSTRAP 8
-
-/**
- * @brief Print messages debugging evaluation.
- *
- * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
- */
#define DEBUG_EVAL 16
-
-/**
- * @brief Print messages debugging input/output operations.
- *
- * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
- */
#define DEBUG_IO 32
-
-/**
- * @brief Print messages debugging lambda functions (interpretation).
- *
- * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
- */
#define DEBUG_LAMBDA 64
-
-/**
- * @brief Print messages debugging the read eval print loop.
- *
- * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
- */
#define DEBUG_REPL 128
-
-/**
- * @brief Print messages debugging stack operations.
- *
- * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
- */
#define DEBUG_STACK 256
-/**
- * @brief Print messages about equality tests.
- *
- * Flag interpretation for the value of `verbosity`, defined in `debug.c`, q.v.
- */
- #define DEBUG_EQUAL 512
-
extern int verbosity;
-void debug_print_exception( struct cons_pointer ex_ptr );
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 );
void debug_dump_object( struct cons_pointer pointer, int level );
-void debug_print_binding( struct cons_pointer key, struct cons_pointer val,
- bool deep, int level );
#endif
diff --git a/src/init.c b/src/init.c
index d88e8aa..676964f 100644
--- a/src/init.c
+++ b/src/init.c
@@ -9,7 +9,6 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
-#include
#include
#include
#include
@@ -20,92 +19,23 @@
/* libcurl, used for io */
#include
-#include "arith/peano.h"
-#include "arith/ratio.h"
-#include "debug.h"
-#include "io/fopen.h"
-#include "io/io.h"
-#include "io/print.h"
+#include "version.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
-#include "memory/hashmap.h"
#include "memory/stack.h"
+#include "debug.h"
+#include "memory/hashmap.h"
#include "ops/intern.h"
+#include "io/io.h"
#include "ops/lispops.h"
#include "ops/meta.h"
+#include "arith/peano.h"
+#include "io/print.h"
#include "repl.h"
+#include "io/fopen.h"
#include "time/psse_time.h"
-#include "version.h"
-/**
- * @brief If `pointer` is an exception, display that exception to stderr,
- * decrement that exception, and return NIL; else return the pointer.
- *
- * @param pointer a cons pointer.
- * @param location_descriptor a description of where the pointer was caught.
- * @return struct cons_pointer
- */
-struct cons_pointer check_exception( struct cons_pointer pointer,
- char *location_descriptor ) {
- struct cons_pointer result = NIL;
-
- struct cons_space_object *object = &pointer2cell( pointer );
-
- if ( exceptionp( pointer ) ) {
- fprintf( stderr, "ERROR: Exception at %s: ", location_descriptor );
- URL_FILE *ustderr = file_to_url_file( stderr );
- fwide( stderr, 1 );
- print( ustderr, object->payload.exception.payload );
- free( ustderr );
-
- dec_ref( pointer );
- } else {
- result = pointer;
- }
-
- return result;
-}
-
-struct cons_pointer init_documentation_symbol = NIL;
-struct cons_pointer init_name_symbol = NIL;
-struct cons_pointer init_primitive_symbol = NIL;
-
-void maybe_bind_init_symbols( ) {
- if ( nilp( init_documentation_symbol ) ) {
- init_documentation_symbol =
- c_string_to_lisp_keyword( L"documentation" );
- }
- if ( nilp( init_name_symbol ) ) {
- init_name_symbol = c_string_to_lisp_keyword( L"name" );
- }
- if ( nilp( init_primitive_symbol ) ) {
- init_primitive_symbol = c_string_to_lisp_keyword( L"primitive" );
- }
- if ( nilp( privileged_symbol_nil ) ) {
- privileged_symbol_nil = c_string_to_lisp_symbol( L"nil" );
- }
- // we can't make this string when we need it, because memory is then
- // exhausted!
- if ( nilp( privileged_string_memory_exhausted ) ) {
- privileged_string_memory_exhausted =
- c_string_to_lisp_string( L"Memory exhausted." );
- }
- if ( nilp( privileged_keyword_location ) ) {
- privileged_keyword_location = c_string_to_lisp_keyword( L"location" );
- }
- if ( nilp( privileged_keyword_payload ) ) {
- privileged_keyword_payload = c_string_to_lisp_keyword( L"payload" );
- }
- if ( nilp( privileged_keyword_cause ) ) {
- privileged_keyword_cause = c_string_to_lisp_keyword( L"cause" );
- }
-}
-
-void free_init_symbols( ) {
- dec_ref( init_documentation_symbol );
- dec_ref( init_name_symbol );
- dec_ref( init_primitive_symbol );
-}
+// extern char *optarg; /* defined in unistd.h */
/**
* Bind this compiled `executable` function, as a Lisp function, to
@@ -114,91 +44,46 @@ void free_init_symbols( ) {
* the name on the source pointer. Would make stack frames potentially
* more readable and aid debugging generally.
*/
-struct cons_pointer bind_function( wchar_t *name,
- wchar_t *doc,
- struct cons_pointer ( *executable )
- ( struct stack_frame *,
- struct cons_pointer,
- struct cons_pointer ) ) {
+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 );
- struct cons_pointer d = c_string_to_lisp_string( doc );
-
struct cons_pointer meta =
- make_cons( make_cons( init_primitive_symbol, TRUE ),
- make_cons( make_cons( init_name_symbol, n ),
- make_cons( make_cons
- ( init_documentation_symbol, d ),
- NIL ) ) );
+ make_cons( make_cons( c_string_to_lisp_keyword( L"primitive" ), TRUE ),
+ make_cons( make_cons( c_string_to_lisp_keyword( L"name" ),
+ n ),
+ NIL ) );
- struct cons_pointer r =
- check_exception( deep_bind( n, make_function( meta, executable ) ),
- "bind_function" );
-
- dec_ref( n );
- dec_ref( d );
-
- return r;
+ deep_bind( n, make_function( meta, executable ) );
}
/**
* Bind this compiled `executable` function, as a Lisp special form, to
* this `name` in the `oblist`.
*/
-struct cons_pointer bind_special( wchar_t *name,
- wchar_t *doc,
- struct cons_pointer ( *executable )
- ( struct stack_frame *, struct cons_pointer,
- struct cons_pointer ) ) {
+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 );
- struct cons_pointer d = c_string_to_lisp_string( doc );
-
struct cons_pointer meta =
- make_cons( make_cons( init_primitive_symbol, TRUE ),
- make_cons( make_cons( init_name_symbol, n ),
- make_cons( make_cons
- ( init_documentation_symbol, d ),
- NIL ) ) );
+ make_cons( make_cons( c_string_to_lisp_keyword( L"primitive" ), TRUE ),
+ make_cons( make_cons( c_string_to_lisp_keyword( L"name" ),
+ n ),
+ NIL ) );
- struct cons_pointer r =
- check_exception( deep_bind( n, make_special( meta, executable ) ),
- "bind_special" );
-
- dec_ref( n );
- dec_ref( d );
-
- return r;
-}
-
-/**
- * Bind this `value` to this `symbol` in the `oblist`.
- */
-struct cons_pointer
-bind_symbol_value( struct cons_pointer symbol, struct cons_pointer value,
- bool lock ) {
- struct cons_pointer r = check_exception( deep_bind( symbol, value ),
- "bind_symbol_value" );
-
- if ( lock && !exceptionp( r ) ) {
- struct cons_space_object *cell = &pointer2cell( r );
-
- cell->count = UINT32_MAX;
- }
-
- return r;
+ deep_bind( n, make_special( meta, executable ) );
}
/**
* Bind this `value` to this `name` in the `oblist`.
*/
-struct cons_pointer bind_value( wchar_t *name, struct cons_pointer value,
- bool lock ) {
- struct cons_pointer p = c_string_to_lisp_symbol( name );
+void bind_value( wchar_t *name, struct cons_pointer value ) {
+ struct cons_pointer n = c_string_to_lisp_symbol( name );
+ inc_ref( n );
- struct cons_pointer r = bind_symbol_value( p, value, lock );
+ deep_bind( n, value );
- dec_ref( p );
-
- return r;
+ dec_ref( n );
}
void print_banner( ) {
@@ -211,15 +96,12 @@ void print_banner( ) {
*
* @stream the stream to print to.
*/
-void print_options( FILE *stream ) {
+void print_options( FILE * stream ) {
fwprintf( stream, L"Expected options are:\n" );
fwprintf( stream,
L"\t-d\tDump memory to standard out at end of run (copious!);\n" );
fwprintf( stream, L"\t-h\tPrint this message and exit;\n" );
fwprintf( stream, L"\t-p\tShow a prompt (default is no prompt);\n" );
- fwprintf( stream,
- L"\t-s LIMIT\n\t\tSet the maximum stack depth to this LIMIT (int)\n" );
-#ifdef DEBUG
fwprintf( stream,
L"\t-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n" );
fwprintf( stream, L"\t\tWhere bits are interpreted as follows:\n" );
@@ -231,9 +113,7 @@ void print_options( FILE *stream ) {
fwprintf( stream, L"\t\t32\tINPUT/OUTPUT;\n" );
fwprintf( stream, L"\t\t64\tLAMBDA;\n" );
fwprintf( stream, L"\t\t128\tREPL;\n" );
- fwprintf( stream, L"\t\t256\tSTACK;\n" );
- fwprintf( stream, L"\t\t512\tEQUAL.\n" );
-#endif
+ fwprintf( stream, L"\t\t256\tSTACK.\n" );
}
/**
@@ -244,7 +124,6 @@ int main( int argc, char *argv[] ) {
int option;
bool dump_at_end = false;
bool show_prompt = false;
- char *infilename = NULL;
setlocale( LC_ALL, "" );
if ( io_init( ) != 0 ) {
@@ -252,7 +131,7 @@ int main( int argc, char *argv[] ) {
exit( 1 );
}
- while ( ( option = getopt( argc, argv, "dhi:ps:v:" ) ) != -1 ) {
+ while ( ( option = getopt( argc, argv, "phdv:" ) ) != -1 ) {
switch ( option ) {
case 'd':
dump_at_end = true;
@@ -262,15 +141,9 @@ int main( int argc, char *argv[] ) {
print_options( stdout );
exit( 0 );
break;
- case 'i':
- infilename = optarg;
- break;
case 'p':
show_prompt = true;
break;
- case 's':
- stack_limit = atoi( optarg );
- break;
case 'v':
verbosity = atoi( optarg );
break;
@@ -282,28 +155,24 @@ int main( int argc, char *argv[] ) {
}
}
- initialise_cons_pages( );
-
- maybe_bind_init_symbols( );
-
-
if ( show_prompt ) {
print_banner( );
}
- debug_print( L"About to initialise oblist\n", DEBUG_BOOTSTRAP );
+ debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP );
- oblist = make_hashmap( 32, NIL, TRUE );
+ initialise_cons_pages( );
- debug_print( L"About to bind\n", DEBUG_BOOTSTRAP );
+ debug_print( L"Initialised cons pages, about to bind\n", DEBUG_BOOTSTRAP );
+
+// TODO: oblist-as-hashmap (which is what we ultimately need) is failing hooribly
+// oblist = inc_ref( make_hashmap( 32, NIL, TRUE ) );
/*
* privileged variables (keywords)
*/
- bind_symbol_value( privileged_symbol_nil, NIL, true );
- bind_value( L"t", TRUE, true );
- bind_symbol_value( privileged_keyword_location, TRUE, true );
- bind_symbol_value( privileged_keyword_payload, TRUE, true );
+ bind_value( L"nil", NIL );
+ bind_value( L"t", TRUE );
/*
* standard input, output, error and sink streams
@@ -314,246 +183,109 @@ int main( int argc, char *argv[] ) {
fwide( stdout, 1 );
fwide( stderr, 1 );
fwide( sink->handle.file, 1 );
-
- FILE *infile = infilename == NULL ? stdin : fopen( infilename, "r" );
-
-
- lisp_io_in =
- bind_value( C_IO_IN,
- make_read_stream( file_to_url_file( infile ),
- make_cons( make_cons
- ( c_string_to_lisp_keyword
- ( L"url" ),
- c_string_to_lisp_string
- ( L"system:standard input" ) ),
- NIL ) ), false );
- lisp_io_out =
- bind_value( C_IO_OUT,
- make_write_stream( file_to_url_file( stdout ),
- make_cons( make_cons
- ( c_string_to_lisp_keyword
- ( L"url" ),
- c_string_to_lisp_string
- ( L"system:standard output" ) ),
- NIL ) ), false );
- bind_value( L"*log*",
- make_write_stream( file_to_url_file( stderr ),
+ bind_value( L"*in*", make_read_stream( file_to_url_file( stdin ),
+ make_cons( make_cons
+ ( c_string_to_lisp_keyword
+ ( L"url" ),
+ c_string_to_lisp_string
+ ( L"system:standard input" ) ),
+ NIL ) ) );
+ bind_value( L"*out*",
+ make_write_stream( file_to_url_file( stdout ),
make_cons( make_cons
( c_string_to_lisp_keyword
( L"url" ),
c_string_to_lisp_string
- ( L"system:standard log" ) ),
- NIL ) ), false );
- bind_value( L"*sink*",
- make_write_stream( sink,
- make_cons( make_cons
- ( c_string_to_lisp_keyword
- ( L"url" ),
- c_string_to_lisp_string
- ( L"system:standard sink" ) ),
- NIL ) ), false );
+ ( L"system:standard output]" ) ),
+ NIL ) ) );
+ bind_value( L"*log*", make_write_stream( file_to_url_file( stderr ),
+ make_cons( make_cons
+ ( c_string_to_lisp_keyword
+ ( L"url" ),
+ c_string_to_lisp_string
+ ( L"system:standard log" ) ),
+ NIL ) ) );
+ bind_value( L"*sink*", make_write_stream( sink,
+ make_cons( make_cons
+ ( c_string_to_lisp_keyword
+ ( L"url" ),
+ c_string_to_lisp_string
+ ( L"system:standard sink" ) ),
+ NIL ) ) );
/*
* the default prompt
*/
- prompt_name = bind_value( L"*prompt*",
- show_prompt ? c_string_to_lisp_symbol( L":: " ) :
- NIL, false );
+ bind_value( L"*prompt*",
+ show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL );
/*
* primitive function operations
*/
- /* TODO: docstrings should be moved to a header file, or even to an at-run-time resolution system.
- * HTTP from an address at journeyman? */
- bind_function( L"absolute",
- L"`(absolute arg)`: If `arg` is a number, return the absolute value of that number, else `nil`.",
- &lisp_absolute );
- bind_function( L"add",
- L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.",
- &lisp_add );
- bind_function( L"and",
- L"`(and args...)`: Return a logical `and` of all the arguments and return `t` only if all are truthy, else `nil`.",
- &lisp_and );
- bind_function( L"append",
- L"`(append args...)`: If args are all collections, return the concatenation of those collections.",
- &lisp_append );
- bind_function( L"apply",
- L"`(apply f args)`: If `f` is usable as a function, and `args` is a collection, apply `f` to `args` and return the value.",
- &lisp_apply );
- bind_function( L"assoc",
- L"`(assoc key store)`: Return the value associated with this `key` in this `store`.",
- &lisp_assoc );
- bind_function( L"car",
- L"`(car arg)`: If `arg` is a sequence, return the item which is the head of that sequence.",
- &lisp_car );
- bind_function( L"cdr",
- L"`(cdr arg)`: If `arg` is a sequence, return the remainder of that sequence with the first item removed.",
- &lisp_cdr );
- bind_function( L"close",
- L"`(close stream)`: If `stream` is a stream, close that stream.",
- &lisp_close );
- bind_function( L"cons",
- L"`(cons a b)`: Return a cons cell whose `car` is `a` and whose `cdr` is `b`.",
- &lisp_cons );
- bind_function( L"count",
- L"`(count s)`: Return the number of items in the sequence `s`.",
- &lisp_count );
- bind_function( L"divide",
- L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.",
- &lisp_divide );
- bind_function( L"eq?",
- L"`(eq? args...)`: Return `t` if all args are the exact same object, else `nil`.",
- &lisp_eq );
- bind_function( L"equal?",
- L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.",
- &lisp_equal );
- bind_function( L"eval", L"", &lisp_eval );
- bind_function( L"exception",
- L"`(exception message)`: Return (throw) an exception with this `message`.",
- &lisp_exception );
- bind_function( L"get-hash",
- L"`(get-hash arg)`: returns the natural number hash value of `arg`.",
- &lisp_get_hash );
- bind_function( L"hashmap",
- L"`(hashmap n-buckets hashfn store acl)`: Return a new hashmap, with `n-buckets` buckets and this `hashfn`, containing the content of this `store`.",
- lisp_make_hashmap );
- bind_function( L"inspect",
- L"`(inspect object ouput-stream)`: Print details of this `object` to this `output-stream` or `*out*`.",
- &lisp_inspect );
- bind_function( L"interned?",
- L"`(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`.",
- &lisp_internedp );
- bind_function( L"keys",
- L"`(keys store)`: Return a list of all keys in this `store`.",
- &lisp_keys );
- bind_function( L"list",
- L"`(list args...)`: Return a list of these `args`.",
- &lisp_list );
- bind_function( L"mapcar",
- L"`(mapcar function sequence)`: Apply `function` to each element of `sequence` in turn, and return a sequence of the results.",
- &lisp_mapcar );
- bind_function( L"meta",
- L"`(meta symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.",
- &lisp_metadata );
- bind_function( L"metadata",
- L"`(metadata symbol)`: If the binding of `symbol` has metadata, return that metadata, else `nil`.",
- &lisp_metadata );
- bind_function( L"multiply",
- L"`(* args...)` Multiply these `args`, all of which should be numbers.",
- &lisp_multiply );
- bind_function( L"negative?",
- L"`(negative? n)`: Return `t` if `n` is a negative number, else `nil`.",
- &lisp_is_negative );
- bind_function( L"not",
- L"`(not arg)`: Return`t` only if `arg` is `nil`, else `nil`.",
- &lisp_not );
- bind_function( L"oblist",
- L"`(oblist)`: Return the current symbol bindings, as a map.",
- &lisp_oblist );
- bind_function( L"open",
- L"`(open url write?)`: Open a stream to this `url`. If `write?` is present and is non-nil, open it for writing, else reading.",
- &lisp_open );
- bind_function( L"or",
- L"`(or args...)`: Return a logical `or` of all the arguments and return `t` if any is truthy, else `nil`.",
- &lisp_or );
- bind_function( L"print",
- L"`(print object stream)`: Print `object` to `stream`, if specified, else to `*out*`.",
- &lisp_print );
- bind_function( L"println",
- L"`(println stream)`: Print a new line character to `stream`, if specified, else to `*out*`.",
- &lisp_print );
- bind_function( L"put!", L"", lisp_hashmap_put );
- bind_function( L"put-all!",
- L"`(put-all! dest source)`: If `dest` is a namespace and is writable, copies all key-value pairs from `source` into `dest`.",
- &lisp_hashmap_put_all );
- bind_function( L"ratio->real",
- L"`(ratio->real r)`: If `r` is a rational number, return the real number equivalent.",
- &lisp_ratio_to_real );
- bind_function( L"read",
- L"`(read stream)`: read one complete lisp form and return it. If `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.",
- &lisp_read );
- bind_function( L"read-char",
- L"`(read-char stream)`: Return the next character. If `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.",
- &lisp_read_char );
- bind_function( L"repl",
- L"`(repl prompt input output)`: Starts a new read-eval-print-loop. All arguments are optional.",
- &lisp_repl );
- bind_function( L"reverse",
- L"`(reverse sequence)` Returns a sequence of the top level elements of this `sequence`, which may be a list or a string, in the reverse order.",
- &lisp_reverse );
- bind_function( L"set", L"", &lisp_set );
- bind_function( L"slurp",
- L"`(slurp read-stream)` Read all the characters from `read-stream` to the end of stream, and return them as a string.",
- &lisp_slurp );
- bind_function( L"source",
- L"`(source object)`: If `object` is an interpreted function or interpreted special form, returns the source code; else nil.",
- &lisp_source );
- bind_function( L"subtract",
- L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.",
- &lisp_subtract );
- bind_function( L"throw", L"", &lisp_exception );
- bind_function( L"time",
- L"`(time arg)`: Return a time object. If an `arg` is supplied, it should be an integer which will be interpreted as a number of microseconds since the big bang, which is assumed to have happened 441,806,400,000,000,000 seconds before the UNIX epoch.",
- &lisp_time );
- bind_function( L"type",
- L"`(type object)`: returns the type of the specified `object`. Currently (0.0.6) the type is returned as a four character string; this may change.",
- &lisp_type );
- bind_function( L"+",
- L"`(+ args...)`: If `args` are all numbers, return the sum of those numbers.",
- &lisp_add );
- bind_function( L"*",
- L"`(* args...)` Multiply these `args`, all of which should be numbers.",
- &lisp_multiply );
- bind_function( L"-",
- L"`(- a b)`: Subtracts `b` from `a` and returns the result. Expects both arguments to be numbers.",
- &lisp_subtract );
- bind_function( L"/",
- L"`(/ a b)`: If `a` and `b` are both numbers, return the numeric result of dividing `a` by `b`.",
- &lisp_divide );
- bind_function( L"=",
- L"`(equal? args...)`: Return `t` if all args have logically equivalent value, else `nil`.",
- &lisp_equal );
+ bind_function( L"absolute", &lisp_absolute );
+ bind_function( L"add", &lisp_add );
+ bind_function( L"append", &lisp_append );
+ 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"get-hash", &lisp_get_hash );
+ bind_function( L"hashmap", lisp_make_hashmap );
+ bind_function( L"inspect", &lisp_inspect );
+ bind_function( L"keys", &lisp_keys );
+ bind_function( L"list", &lisp_list );
+ bind_function( L"mapcar", &lisp_mapcar );
+ bind_function( L"meta", &lisp_metadata );
+ bind_function( L"metadata", &lisp_metadata );
+ bind_function( L"multiply", &lisp_multiply );
+ 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"put!", lisp_hashmap_put );
+ bind_function( L"put-all!", &lisp_hashmap_put_all );
+ 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"time", &lisp_time );
+ bind_function( L"type", &lisp_type );
+ bind_function( L"+", &lisp_add );
+ bind_function( L"*", &lisp_multiply );
+ bind_function( L"-", &lisp_subtract );
+ bind_function( L"/", &lisp_divide );
+ bind_function( L"=", &lisp_equal );
/*
* primitive special forms
*/
- bind_special( L"cond",
- L"`(cond clauses...)`: Conditional evaluation, `clauses` is a sequence of lists of forms such that if evaluating the first form in any clause returns non-`nil`, the subsequent forms in that clause will be evaluated and the value of the last returned; but any subsequent clauses will not be evaluated.",
- &lisp_cond );
- bind_special( L"lambda",
- L"`(lambda arg-list forms...)`: Construct an interpretable λ funtion.",
- &lisp_lambda );
- bind_special( L"\u03bb", L"", &lisp_lambda ); // λ
- bind_special( L"let",
- L"`(let bindings forms)`: Bind these `bindings`, which should be specified as an association list, into the local environment and evaluate these forms sequentially in that context, returning the value of the last.",
- &lisp_let );
- bind_special( L"nlambda",
- L"`(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated.",
- &lisp_nlambda );
- bind_special( L"n\u03bb", L"`(nlamda arg-list forms...)`: Construct an interpretable special form. When the form is interpreted, arguments specified in the `arg-list` will not be evaluated.", &lisp_nlambda ); // nλ
- bind_special( L"progn",
- L"`(progn forms...)` Evaluate `forms` sequentially, and return the value of the last.",
- &lisp_progn );
- bind_special( L"quote",
- L"`(quote form)`: Returns `form`, unevaluated. More idiomatically expressed `'form`, where the quote mark is a reader macro which is expanded to `(quote form)`.",
- &lisp_quote );
- bind_special( L"set!",
- L"`(set! symbol value namespace)`: Binds `symbol` in `namespace` to the value of `value`, altering the namespace in so doing, and returns `value`. If `namespace` is not specified, it defaults to the default namespace.",
- &lisp_set_shriek );
- bind_special( L"try", L"", &lisp_try );
+ bind_special( L"cond", &lisp_cond );
+ bind_special( L"lambda", &lisp_lambda );
+ bind_special( L"\u03bb", &lisp_lambda ); // λ
+ bind_special( L"let", &lisp_let );
+ bind_special( L"nlambda", &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 );
+ bind_special( L"try", &lisp_try );
debug_print( L"Initialised oblist\n", DEBUG_BOOTSTRAP );
debug_dump_object( oblist, DEBUG_BOOTSTRAP );
repl( show_prompt );
- debug_dump_object( oblist, DEBUG_BOOTSTRAP );
-
debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP );
- while ( ( pointer2cell( oblist ) ).count > 0 ) {
- fprintf( stderr, "Dangling refs on oblist: %d\n",
- ( pointer2cell( oblist ) ).count );
- dec_ref( oblist );
- }
-
- free_init_symbols( );
-
+ dec_ref( oblist );
+ debug_dump_object( oblist, DEBUG_BOOTSTRAP );
if ( dump_at_end ) {
dump_pages( file_to_url_file( stdout ) );
}
diff --git a/src/io/fopen.c b/src/io/fopen.c
index bf918ec..e4fafdd 100644
--- a/src/io/fopen.c
+++ b/src/io/fopen.c
@@ -99,7 +99,7 @@ static size_t write_callback( char *buffer,
}
/* use to attempt to fill the read buffer up to requested number of bytes */
-static int fill_buffer( URL_FILE *file, size_t want ) {
+static int fill_buffer( URL_FILE * file, size_t want ) {
fd_set fdread;
fd_set fdwrite;
fd_set fdexcep;
@@ -181,7 +181,7 @@ static int fill_buffer( URL_FILE *file, size_t want ) {
}
/* use to remove want bytes from the front of a files buffer */
-static int use_buffer( URL_FILE *file, size_t want ) {
+static int use_buffer( URL_FILE * file, size_t want ) {
/* sort out buffer */
if ( ( file->buffer_pos - want ) <= 0 ) {
/* ditch buffer - write will recreate */
@@ -255,7 +255,7 @@ URL_FILE *url_fopen( const char *url, const char *operation ) {
return file;
}
-int url_fclose( URL_FILE *file ) {
+int url_fclose( URL_FILE * file ) {
int ret = 0; /* default is good return */
switch ( file->type ) {
@@ -283,7 +283,7 @@ int url_fclose( URL_FILE *file ) {
return ret;
}
-int url_feof( URL_FILE *file ) {
+int url_feof( URL_FILE * file ) {
int ret = 0;
switch ( file->type ) {
@@ -304,7 +304,7 @@ int url_feof( URL_FILE *file ) {
return ret;
}
-size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE *file ) {
+size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ) {
size_t want;
switch ( file->type ) {
@@ -343,7 +343,7 @@ size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE *file ) {
return want;
}
-char *url_fgets( char *ptr, size_t size, URL_FILE *file ) {
+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;
@@ -390,7 +390,7 @@ char *url_fgets( char *ptr, size_t size, URL_FILE *file ) {
return ptr; /*success */
}
-void url_rewind( URL_FILE *file ) {
+void url_rewind( URL_FILE * file ) {
switch ( file->type ) {
case CFTYPE_FILE:
rewind( file->handle.file ); /* passthrough */
diff --git a/src/io/history.c b/src/io/history.c
deleted file mode 100644
index 417a6b1..0000000
--- a/src/io/history.c
+++ /dev/null
@@ -1,14 +0,0 @@
-/*
- * history.c
- *
- * Maintain, and recall, a history of things which have been read from standard
- * input. Necessarily the history must be stored on the user session, and not be
- * global.
- *
- * I *think* history will be maintained as a list of forms, not of strings, so
- * only forms which have successfully been read can be recalled, and forms which
- * have not been completed when the history function is invoked will be lost.
- *
- * (c) 2025 Simon Brooke
- * Licensed under GPL version 2.0, or, at your option, any later version.
- */
diff --git a/src/io/history.h b/src/io/history.h
deleted file mode 100644
index ffdd262..0000000
--- a/src/io/history.h
+++ /dev/null
@@ -1,14 +0,0 @@
-/*
- * history.h
- *
- * Maintain, and recall, a history of things which have been read from standard
- * input. Necessarily the history must be stored on the user session, and not be
- * global.
- *
- * I *think* history will be maintained as a list of forms, not of strings, so
- * only forms which have successfully been read can be recalled, and forms which
- * have not been completed when the history function is invoked will be lost.
- *
- * (c) 2025 Simon Brooke
- * Licensed under GPL version 2.0, or, at your option, any later version.
- */
diff --git a/src/io/io.c b/src/io/io.c
index cf0894f..d01f788 100644
--- a/src/io/io.c
+++ b/src/io/io.c
@@ -28,12 +28,11 @@
#include
-#include "arith/integer.h"
-#include "debug.h"
-#include "io/fopen.h"
-#include "io/io.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
+#include "debug.h"
+#include "io/fopen.h"
+#include "arith/integer.h"
#include "ops/intern.h"
#include "ops/lispops.h"
#include "utils.h"
@@ -45,16 +44,6 @@
*/
CURLSH *io_share;
-/**
- * @brief bound to the Lisp string representing C_IO_IN in initialisation.
- */
-struct cons_pointer lisp_io_in = NIL;
-/**
- * @brief bound to the Lisp string representing C_IO_OUT in initialisation.
- */
-struct cons_pointer lisp_io_out = NIL;
-
-
/**
* Allow a one-character unget facility. This may not be enough - we may need
* to allocate a buffer.
@@ -131,7 +120,7 @@ char *lisp_string_to_c_string( struct cons_pointer s ) {
* @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 *file_to_url_file( FILE * f ) {
URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) );
if ( result != NULL ) {
@@ -148,7 +137,7 @@ URL_FILE *file_to_url_file( FILE *f ) {
* @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 url_fgetwc( URL_FILE * input ) {
wint_t result = -1;
if ( ungotten != 0 ) {
@@ -217,7 +206,7 @@ wint_t url_fgetwc( URL_FILE *input ) {
return result;
}
-wint_t url_ungetwc( wint_t wc, URL_FILE *input ) {
+wint_t url_ungetwc( wint_t wc, URL_FILE * input ) {
wint_t result = -1;
switch ( input->type ) {
@@ -284,7 +273,7 @@ struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key,
}
struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key,
- time_t *value ) {
+ time_t * value ) {
/* I don't yet have a concept of a date-time object, which is a
* bit of an oversight! */
char datestring[256];
@@ -410,22 +399,27 @@ void collect_meta( struct cons_pointer stream, char *url ) {
*/
struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) {
struct cons_pointer result = NIL;
- struct cons_pointer stream_name = inputp ? lisp_io_in : lisp_io_out;
+ 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: 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 writing. At
+ * 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.
*
- * * (open url)
+ * * (read-char stream)
*
* @param frame my stack_frame.
* @param frame_pointer a pointer to my stack_frame.
@@ -508,8 +502,8 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( readp( frame->arg[0] ) ) {
result =
make_string( url_fgetwc
- ( pointer2cell( frame->arg[0] ).payload.
- stream.stream ), NIL );
+ ( pointer2cell( frame->arg[0] ).payload.stream.
+ stream ), NIL );
}
return result;
@@ -519,8 +513,6 @@ lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer,
* Function: return a string representing all characters from the stream
* indicated by arg 0; further arguments are ignored.
*
- * TODO: it should be possible to optionally pass a string URL to this function,
- *
* * (slurp stream)
*
* @param frame my stack_frame.
diff --git a/src/io/io.h b/src/io/io.h
index 0f971a3..f350c13 100644
--- a/src/io/io.h
+++ b/src/io/io.h
@@ -11,18 +11,12 @@
#ifndef __psse_io_h
#define __psse_io_h
#include
-#include "memory/consspaceobject.h"
+#include "consspaceobject.h"
extern CURLSH *io_share;
int io_init( );
-#define C_IO_IN L"*in*"
-#define C_IO_OUT L"*out*"
-
-extern struct cons_pointer lisp_io_in;
-extern struct cons_pointer lisp_io_out;
-
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 );
@@ -42,5 +36,5 @@ struct cons_pointer
lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env );
-char *lisp_string_to_c_string( struct cons_pointer s );
+
#endif
diff --git a/src/io/print.c b/src/io/print.c
index f5f80a5..8f4b88e 100644
--- a/src/io/print.c
+++ b/src/io/print.c
@@ -17,24 +17,22 @@
#include
#include
-#include "arith/integer.h"
-#include "debug.h"
-#include "io/io.h"
-#include "io/print.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "memory/hashmap.h"
-#include "memory/stack.h"
-#include "memory/vectorspace.h"
+#include "arith/integer.h"
#include "ops/intern.h"
+#include "memory/stack.h"
+#include "io/print.h"
#include "time/psse_time.h"
+#include "memory/vectorspace.h"
/**
* print all the characters in the symbol or string indicated by `pointer`
* onto this `output`; if `pointer` does not indicate a string or symbol,
* don't print anything but just return.
*/
-void print_string_contents( URL_FILE *output, struct cons_pointer pointer ) {
+void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) {
while ( stringp( pointer ) || symbolp( pointer ) || keywordp( pointer ) ) {
struct cons_space_object *cell = &pointer2cell( pointer );
wchar_t c = cell->payload.string.character;
@@ -51,7 +49,7 @@ void print_string_contents( URL_FILE *output, struct cons_pointer pointer ) {
* the stream at this `output`, prepending and appending double quote
* characters.
*/
-void print_string( URL_FILE *output, struct cons_pointer pointer ) {
+void print_string( URL_FILE * output, struct cons_pointer pointer ) {
url_fputwc( btowc( '"' ), output );
print_string_contents( output, pointer );
url_fputwc( btowc( '"' ), output );
@@ -63,7 +61,7 @@ void print_string( URL_FILE *output, struct cons_pointer pointer ) {
* a space character.
*/
void
-print_list_contents( URL_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 );
@@ -84,13 +82,13 @@ print_list_contents( URL_FILE *output, struct cons_pointer pointer,
}
}
-void print_list( URL_FILE *output, struct cons_pointer pointer ) {
+void print_list( URL_FILE * output, struct cons_pointer pointer ) {
url_fputws( L"(", output );
print_list_contents( output, pointer, false );
url_fputws( L")", output );
}
-void print_map( URL_FILE *output, struct cons_pointer map ) {
+void print_map( URL_FILE * output, struct cons_pointer map ) {
if ( hashmapp( map ) ) {
struct vector_space_object *vso = pointer_to_vso( map );
@@ -101,7 +99,7 @@ void print_map( URL_FILE *output, struct cons_pointer map ) {
struct cons_pointer key = c_car( ks );
print( output, key );
url_fputwc( btowc( ' ' ), output );
- print( output, hashmap_get( map, key, false ) );
+ print( output, hashmap_get( map, key ) );
if ( !nilp( c_cdr( ks ) ) ) {
url_fputws( L", ", output );
@@ -112,15 +110,12 @@ void print_map( URL_FILE *output, struct cons_pointer map ) {
}
}
-void print_vso( URL_FILE *output, struct cons_pointer pointer ) {
+void print_vso( URL_FILE * output, struct cons_pointer pointer ) {
struct vector_space_object *vso = pointer_to_vso( pointer );
switch ( vso->header.tag.value ) {
case HASHTV:
print_map( output, pointer );
break;
- case STACKFRAMETV:
- dump_stack_trace( output, pointer );
- break;
// \todo: others.
default:
fwprintf( stderr, L"Unrecognised vector-space type '%d'\n",
@@ -131,7 +126,7 @@ void print_vso( URL_FILE *output, struct cons_pointer pointer ) {
/**
* stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc
*/
-void print_128bit( URL_FILE *output, __int128_t n ) {
+void print_128bit( URL_FILE * output, __int128_t n ) {
if ( n == 0 ) {
fwprintf( stderr, L"0" );
} else {
@@ -153,7 +148,7 @@ void print_128bit( URL_FILE *output, __int128_t n ) {
* Print the cons-space object indicated by `pointer` to the stream indicated
* by `output`.
*/
-struct cons_pointer print( URL_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;
@@ -174,10 +169,12 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) {
print( output, cell.payload.function.meta );
url_fputwc( L'>', output );
break;
- case INTEGERTV:
- struct cons_pointer s = integer_to_string( pointer, 10 );
- print_string_contents( output, s );
- dec_ref( s );
+ case INTEGERTV:{
+ struct cons_pointer s = integer_to_string( pointer, 10 );
+ inc_ref( s );
+ print_string_contents( output, s );
+ dec_ref( s );
+ }
break;
case KEYTV:
url_fputws( L":", output );
@@ -189,6 +186,7 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) {
make_cons( c_string_to_lisp_symbol( L"\u03bb" ),
make_cons( cell.payload.lambda.args,
cell.payload.lambda.body ) );
+ inc_ref( to_print );
print( output, to_print );
@@ -205,6 +203,7 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) {
make_cons( c_string_to_lisp_symbol( L"n\u03bb" ),
make_cons( cell.payload.lambda.args,
cell.payload.lambda.body ) );
+ inc_ref( to_print );
print( output, to_print );
@@ -253,7 +252,7 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) {
url_fwprintf( output, L"', output );
break;
case TRUETV:
@@ -271,88 +270,12 @@ struct cons_pointer print( URL_FILE *output, struct cons_pointer pointer ) {
fwprintf( stderr,
L"Error: Unrecognised tag value %d (%4.4s)\n",
cell.tag.value, &cell.tag.bytes[0] );
- // dump_object( stderr, pointer);
break;
}
return pointer;
}
-/**
- * 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 (from which the stream may be extracted).
- * @return NIL.
- */
-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;
- 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( stderr );
- }
-
- debug_print( L"lisp_print: about to print\n", DEBUG_IO );
- debug_dump_object( frame->arg[0], DEBUG_IO );
-
- result = print( output, frame->arg[0] );
-
- 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;
-}
-
-void println( URL_FILE *output ) {
+void println( URL_FILE * output ) {
url_fputws( L"\n", output );
}
-
-/**
- * @brief `(prinln out-stream)`: Print a new line character to `out-stream`, if
- * it is specified and is an output stream, else to `*out*`.
- *
- * @param frame
- * @param frame_pointer
- * @param env
- * @return `nil`
- */
-struct cons_pointer
-lisp_println( struct stack_frame *frame, struct cons_pointer frame_pointer,
- struct cons_pointer env ) {
- URL_FILE *output;
- struct cons_pointer out_stream = writep( frame->arg[1] ) ?
- frame->arg[1] : get_default_stream( false, env );
-
- if ( writep( out_stream ) ) {
- output = pointer2cell( out_stream ).payload.stream.stream;
-
- println( output );
-
- free( output );
- }
-
- return NIL;
-}
diff --git a/src/io/print.h b/src/io/print.h
index bde68fb..006ef80 100644
--- a/src/io/print.h
+++ b/src/io/print.h
@@ -11,20 +11,10 @@
#include
#include
-#include "io/fopen.h"
-
#ifndef __print_h
#define __print_h
struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer );
void println( URL_FILE * output );
-struct cons_pointer lisp_print( struct stack_frame *frame,
- struct cons_pointer frame_pointer,
- struct cons_pointer env );
-struct cons_pointer lisp_println( struct stack_frame *frame,
- struct cons_pointer frame_pointer,
- struct cons_pointer env );
-
-
#endif
diff --git a/src/io/read.c b/src/io/read.c
index fee80b3..bf92f35 100644
--- a/src/io/read.c
+++ b/src/io/read.c
@@ -32,16 +32,6 @@
#include "arith/real.h"
#include "memory/vectorspace.h"
-// We can't, I think, use libreadline, because we read character by character,
-// not line by line, and because we use wide characters. So we're going to have
-// to reimplement it. So we're going to have to maintain history of the forms
-// (or strings, but I currently think forms). So we're going to have to be able
-// to detact special keys, particularly, at this stage, the uparrow and down-
-// arrow keys
-// #include
-// #include
-
-
/*
* for the time being things which may be read are:
* * strings
@@ -83,14 +73,14 @@ struct cons_pointer c_quote( struct cons_pointer arg ) {
* 3. one or more symbols separated by slashes; or
* 4. keywords (with leading colons) interspersed with symbols (prefixed by slashes).
*/
-struct cons_pointer read_path( URL_FILE *input, wint_t initial,
+struct cons_pointer read_path( URL_FILE * input, wint_t initial,
struct cons_pointer q ) {
bool done = false;
struct cons_pointer prefix = NIL;
switch ( initial ) {
case '/':
- prefix = make_cons( c_string_to_lisp_symbol( L"oblist" ), NIL );
+ prefix = c_string_to_lisp_symbol( L"oblist" );
break;
case '$':
case LSESSION:
@@ -155,7 +145,7 @@ struct cons_pointer read_path( URL_FILE *input, wint_t initial,
struct cons_pointer read_continuation( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env,
- URL_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;
@@ -167,8 +157,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
if ( url_feof( input ) ) {
result =
- throw_exception( c_string_to_lisp_symbol( L"read" ),
- c_string_to_lisp_string
+ throw_exception( c_string_to_lisp_string
( L"End of file while reading" ), frame_pointer );
} else {
switch ( c ) {
@@ -178,8 +167,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
/* skip all characters from semi-colon to the end of the line */
break;
case EOF:
- result = throw_exception( c_string_to_lisp_symbol( L"read" ),
- c_string_to_lisp_string
+ result = throw_exception( c_string_to_lisp_string
( L"End of input while reading" ),
frame_pointer );
break;
@@ -268,8 +256,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
result = read_symbol_or_key( input, SYMBOLTV, c );
} else {
result =
- throw_exception( c_string_to_lisp_symbol( L"read" ),
- make_cons( c_string_to_lisp_string
+ throw_exception( make_cons( c_string_to_lisp_string
( L"Unrecognised start of input character" ),
make_string( c, NIL ) ),
frame_pointer );
@@ -290,14 +277,14 @@ struct cons_pointer read_continuation( struct stack_frame *frame,
*/
struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer frame_pointer,
- URL_FILE *input,
+ URL_FILE * input,
wint_t initial, bool seen_period ) {
debug_print( L"entering read_number\n", DEBUG_IO );
- struct cons_pointer result = acquire_integer( 0, NIL );
+ 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 = acquire_integer( 10, NIL );
+ struct cons_pointer base = make_integer( 10, NIL );
struct cons_pointer dividend = NIL;
int places_of_decimals = 0;
wint_t c;
@@ -311,13 +298,11 @@ struct cons_pointer read_number( struct stack_frame *frame,
initial );
for ( c = initial; iswdigit( c )
- || c == LPERIOD || c == LSLASH || c == LCOMMA;
- c = url_fgetwc( input ) ) {
+ || c == LPERIOD || c == LSLASH || c == LCOMMA; c = url_fgetwc( input ) ) {
switch ( c ) {
case LPERIOD:
if ( seen_period || !nilp( dividend ) ) {
- return throw_exception( c_string_to_lisp_symbol( L"read" ),
- c_string_to_lisp_string
+ return throw_exception( c_string_to_lisp_string
( L"Malformed number: too many periods" ),
frame_pointer );
} else {
@@ -328,8 +313,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
break;
case LSLASH:
if ( seen_period || !nilp( dividend ) ) {
- return throw_exception( c_string_to_lisp_symbol( L"read" ),
- c_string_to_lisp_string
+ return throw_exception( c_string_to_lisp_string
( L"Malformed number: dividend of rational must be integer" ),
frame_pointer );
} else {
@@ -337,19 +321,17 @@ struct cons_pointer read_number( struct stack_frame *frame,
DEBUG_IO );
dividend = result;
- result = acquire_integer( 0, NIL );
- // If I do replace_integer_p here instead of acquire_integer,
- // and thus reclaim the garbage, I get a regression. Dom't yet
- // know why.
+ result = make_integer( 0, NIL );
}
break;
case LCOMMA:
- // silently ignore comma.
+ // silently ignore it.
break;
default:
result = add_integers( multiply_integers( result, base ),
- acquire_integer( ( int ) c -
- ( int ) '0', NIL ) );
+ /* /todo: this won't work for hex digits */
+ make_integer( ( int ) c - ( int ) '0',
+ NIL ) );
debug_printf( DEBUG_IO,
L"read_number: added character %c, result now ",
@@ -371,11 +353,11 @@ struct cons_pointer read_number( struct stack_frame *frame,
if ( seen_period ) {
debug_print( L"read_number: converting result to real\n", DEBUG_IO );
struct cons_pointer div = make_ratio( result,
- acquire_integer( powl
- ( to_long_double
- ( base ),
- places_of_decimals ),
- NIL ), true );
+ make_integer( powl
+ ( to_long_double
+ ( base ),
+ places_of_decimals ),
+ NIL ) );
inc_ref( div );
result = make_real( to_long_double( div ) );
@@ -383,7 +365,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
dec_ref( div );
} else if ( integerp( dividend ) ) {
debug_print( L"read_number: converting result to ratio\n", DEBUG_IO );
- result = make_ratio( dividend, result, true );
+ result = make_ratio( dividend, result );
}
if ( neg ) {
@@ -406,7 +388,7 @@ struct cons_pointer read_number( struct stack_frame *frame,
struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env,
- URL_FILE *input, wint_t initial ) {
+ URL_FILE * input, wint_t initial ) {
struct cons_pointer result = NIL;
wint_t c;
@@ -446,7 +428,7 @@ struct cons_pointer read_list( struct stack_frame *frame,
struct cons_pointer read_map( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env,
- URL_FILE *input, wint_t initial ) {
+ URL_FILE * input, wint_t initial ) {
// set write ACL to true whilst creating to prevent GC churn
struct cons_pointer result =
make_hashmap( DFLT_HASHMAP_BUCKETS, NIL, TRUE );
@@ -486,7 +468,7 @@ struct cons_pointer read_map( 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( URL_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 ) {
@@ -509,7 +491,7 @@ struct cons_pointer read_string( URL_FILE *input, wint_t initial ) {
return result;
}
-struct cons_pointer read_symbol_or_key( URL_FILE *input, uint32_t tag,
+struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag,
wint_t initial ) {
struct cons_pointer cdr = NIL;
struct cons_pointer result;
@@ -564,7 +546,7 @@ struct cons_pointer read_symbol_or_key( URL_FILE *input, uint32_t tag,
struct cons_pointer read( struct
stack_frame
*frame, struct cons_pointer frame_pointer,
- struct cons_pointer env, URL_FILE *input ) {
+ struct cons_pointer env, URL_FILE * input ) {
return read_continuation( frame, frame_pointer, env, input,
url_fgetwc( input ) );
}
diff --git a/src/memory/conspage.c b/src/memory/conspage.c
index 3d96647..f8802cc 100644
--- a/src/memory/conspage.c
+++ b/src/memory/conspage.c
@@ -45,12 +45,6 @@ int initialised_cons_pages = 0;
*/
struct cons_pointer freelist = NIL;
-/**
- * The exception message printed when the world blows up, initialised in
- * `maybe_bind_init_symbols()` in `init.c`, q.v.
- */
-struct cons_pointer privileged_string_memory_exhausted;
-
/**
* An array of pointers to cons pages.
*/
@@ -127,17 +121,14 @@ void make_cons_page( ) {
/**
* dump the allocated pages to this `output` stream.
*/
-void dump_pages( URL_FILE *output ) {
+void dump_pages( URL_FILE * output ) {
for ( int i = 0; i < initialised_cons_pages; i++ ) {
url_fwprintf( output, L"\nDUMPING PAGE %d\n", i );
for ( int j = 0; j < CONSPAGESIZE; j++ ) {
- struct cons_pointer pointer = ( struct cons_pointer ) { i, j };
- if ( !freep( pointer ) ) {
- dump_object( output, ( struct cons_pointer ) {
- i, j
- } );
- }
+ dump_object( output, ( struct cons_pointer ) {
+ i, j
+ } );
}
}
}
@@ -196,9 +187,6 @@ void free_cell( struct cons_pointer pointer ) {
case VECTORPOINTTV:
free_vso( pointer );
break;
- default:
- fprintf( stderr, "WARNING: Freeing object of type %s!",
- ( char * ) &( cell->tag.bytes ) );
}
strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH );
@@ -243,16 +231,15 @@ struct cons_pointer allocate_cell( uint32_t tag ) {
cell->tag.value = tag;
- cell->count = 1;
+ cell->count = 0;
cell->payload.cons.car = NIL;
cell->payload.cons.cdr = NIL;
total_cells_allocated++;
debug_printf( DEBUG_ALLOC,
- L"Allocated cell of type %4.4s at %u, %u \n",
- ( ( char * ) cell->tag.bytes ), result.page,
- result.offset );
+ L"Allocated cell of type '%4.4s' at %d, %d \n", tag,
+ result.page, result.offset );
} else {
debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" );
}
@@ -280,7 +267,6 @@ void initialise_cons_pages( ) {
void summarise_allocation( ) {
fwprintf( stderr,
- L"Allocation summary: allocated %lld; deallocated %lld; not deallocated %lld.\n",
- total_cells_allocated, total_cells_freed,
- total_cells_allocated - total_cells_freed );
+ L"Allocation summary: allocated %lld; deallocated %lld.\n",
+ total_cells_allocated, total_cells_freed );
}
diff --git a/src/memory/conspage.h b/src/memory/conspage.h
index 3bad3ae..589f6bf 100644
--- a/src/memory/conspage.h
+++ b/src/memory/conspage.h
@@ -49,8 +49,6 @@ struct cons_page {
struct cons_space_object cell[CONSPAGESIZE];
};
-extern struct cons_pointer privileged_string_memory_exhausted;
-
extern struct cons_pointer freelist;
extern struct cons_page *conspages[NCONSPAGES];
diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c
index ffff610..579e84b 100644
--- a/src/memory/consspaceobject.c
+++ b/src/memory/consspaceobject.c
@@ -9,9 +9,9 @@
*/
#include
-#include
#include
#include
+#include
/*
* wide characters
*/
@@ -19,31 +19,13 @@
#include
#include "authorise.h"
-#include "debug.h"
-#include "io/print.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
+#include "debug.h"
+#include "ops/intern.h"
+#include "io/print.h"
#include "memory/stack.h"
#include "memory/vectorspace.h"
-#include "ops/intern.h"
-
-/**
- * Keywords used when constructing exceptions: `:location`. Instantiated in
- * `init.c`q.v.
- */
-struct cons_pointer privileged_keyword_location = NIL;
-
-/**
- * Keywords used when constructing exceptions: `:payload`. Instantiated in
- * `init.c`, q.v.
- */
-struct cons_pointer privileged_keyword_payload = NIL;
-
-/**
- * Keywords used when constructing exceptions: `:payload`. Instantiated in
- * `init.c`, q.v.
- */
-struct cons_pointer privileged_keyword_cause = NIL;
/**
* True if the value of the tag on the cell at this `pointer` is this `value`,
@@ -53,11 +35,11 @@ struct cons_pointer privileged_keyword_cause = NIL;
bool check_tag( struct cons_pointer pointer, uint32_t value ) {
bool result = false;
- struct cons_space_object *cell = &pointer2cell( pointer );
- result = cell->tag.value == value;
+ struct cons_space_object cell = pointer2cell( pointer );
+ result = cell.tag.value == value;
if ( result == false ) {
- if ( cell->tag.value == VECTORPOINTTV ) {
+ if ( cell.tag.value == VECTORPOINTTV ) {
struct vector_space_object *vec = pointer_to_vso( pointer );
if ( vec != NULL ) {
@@ -74,7 +56,7 @@ bool check_tag( struct cons_pointer pointer, uint32_t value ) {
*
* You can't roll over the reference count. Once it hits the maximum
* value you cannot increment further.
- *
+ *
* Returns the `pointer`.
*/
struct cons_pointer inc_ref( struct cons_pointer pointer ) {
@@ -82,19 +64,6 @@ struct cons_pointer inc_ref( struct cons_pointer pointer ) {
if ( cell->count < MAXREFERENCE ) {
cell->count++;
-#ifdef DEBUG
- debug_printf( DEBUG_ALLOC,
- L"\nIncremented cell of type %4.4s at page %u, offset %u to count %u",
- ( ( char * ) cell->tag.bytes ), pointer.page,
- pointer.offset, cell->count );
- if ( strncmp( cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH ) == 0 ) {
- debug_printf( DEBUG_ALLOC,
- L"; pointer to vector object of type %4.4s.\n",
- ( ( char * ) ( cell->payload.vectorp.tag.bytes ) ) );
- } else {
- debug_println( DEBUG_ALLOC );
- }
-#endif
}
return pointer;
@@ -105,28 +74,14 @@ struct cons_pointer inc_ref( struct cons_pointer pointer ) {
*
* If a count has reached MAXREFERENCE it cannot be decremented.
* If a count is decremented to zero the cell should be freed.
- *
+ *
* Returns the `pointer`, or, if the cell has been freed, NIL.
*/
struct cons_pointer dec_ref( struct cons_pointer pointer ) {
struct cons_space_object *cell = &pointer2cell( pointer );
- if ( cell->count > 0 && cell->count != UINT32_MAX ) {
+ if ( cell->count > 0 ) {
cell->count--;
-#ifdef DEBUG
- debug_printf( DEBUG_ALLOC,
- L"\nDecremented cell of type %4.4s at page %d, offset %d to count %d",
- ( ( char * ) cell->tag.bytes ), pointer.page,
- pointer.offset, cell->count );
- if ( strncmp( ( char * ) cell->tag.bytes, VECTORPOINTTAG, TAGLENGTH )
- == 0 ) {
- debug_printf( DEBUG_ALLOC,
- L"; pointer to vector object of type %4.4s.\n",
- ( ( char * ) ( cell->payload.vectorp.tag.bytes ) ) );
- } else {
- debug_println( DEBUG_ALLOC );
- }
-#endif
if ( cell->count == 0 ) {
free_cell( pointer );
@@ -137,18 +92,6 @@ struct cons_pointer dec_ref( struct cons_pointer pointer ) {
return pointer;
}
-/**
- * given a cons_pointer as argument, return the tag.
- */
-uint32_t get_tag_value( struct cons_pointer pointer ) {
- uint32_t result = pointer2cell( pointer ).tag.value;
-
- if ( result == VECTORPOINTTV ) {
- result = pointer_to_vso( pointer )->header.tag.value;
- }
-
- return result;
-}
/**
* Get the Lisp type of the single argument.
@@ -156,15 +99,11 @@ uint32_t get_tag_value( struct cons_pointer pointer ) {
* @return As a Lisp string, the tag of the object which is at that pointer.
*/
struct cons_pointer c_type( struct cons_pointer pointer ) {
- /* Strings read by `read` have the null character termination. This means
- * that for the same printable string, the hashcode is different from
- * strings made with NIL termination. The question is which should be
- * fixed, and actually that's probably strings read by `read`. However,
- * for now, it was easier to add a null character here. */
- struct cons_pointer result = make_string( ( wchar_t ) 0, NIL );
- struct cons_space_object *cell = &pointer2cell( pointer );
+ struct cons_pointer result = NIL;
+ struct cons_space_object cell = pointer2cell( pointer );
- if ( cell->tag.value == VECTORPOINTTV ) {
+ if ( strncmp( ( char * ) &cell.tag.bytes, VECTORPOINTTAG, TAGLENGTH ) ==
+ 0 ) {
struct vector_space_object *vec = pointer_to_vso( pointer );
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
@@ -173,7 +112,7 @@ struct cons_pointer c_type( struct cons_pointer pointer ) {
}
} else {
for ( int i = TAGLENGTH - 1; i >= 0; i-- ) {
- result = make_string( ( wchar_t ) cell->tag.bytes[i], result );
+ result = make_string( ( wchar_t ) cell.tag.bytes[i], result );
}
}
@@ -196,7 +135,7 @@ struct cons_pointer c_car( struct cons_pointer arg ) {
/**
* Implementation of cdr in C. If arg is not a sequence, or the current user is
- * not authorised to read it, does not error but returns nil.
+ * not authorised to read it,does not error but returns nil.
*/
struct cons_pointer c_cdr( struct cons_pointer arg ) {
struct cons_pointer result = NIL;
@@ -220,8 +159,7 @@ struct cons_pointer c_cdr( struct cons_pointer arg ) {
}
/**
- * Implementation of `length` in C. If arg is not a cons, does not error but
- * returns 0.
+ * Implementation of `length` in C. If arg is not a cons, does not error but returns 0.
*/
int c_length( struct cons_pointer arg ) {
int result = 0;
@@ -233,6 +171,7 @@ int c_length( struct cons_pointer arg ) {
return result;
}
+
/**
* Construct a cons cell from this pair of pointers.
*/
@@ -254,10 +193,8 @@ struct cons_pointer make_cons( struct cons_pointer car,
/**
* Construct an exception cell.
- * @param message should be a lisp string describing the problem, but actually
- * any cons pointer will do;
- * @param frame_pointer should be the pointer to the frame in which the
- * exception occurred.
+ * @param message should be a lisp string describing the problem, but actually any cons pointer will do;
+ * @param frame_pointer should be the pointer to the frame in which the exception occurred.
*/
struct cons_pointer make_exception( struct cons_pointer message,
struct cons_pointer frame_pointer ) {
@@ -265,6 +202,7 @@ struct cons_pointer make_exception( struct cons_pointer message,
struct cons_pointer pointer = allocate_cell( EXCEPTIONTV );
struct cons_space_object *cell = &pointer2cell( pointer );
+ inc_ref( message );
inc_ref( frame_pointer );
cell->payload.exception.payload = message;
cell->payload.exception.frame = frame_pointer;
@@ -274,18 +212,14 @@ struct cons_pointer make_exception( struct cons_pointer message,
return result;
}
+
/**
* Construct a cell which points to an executable Lisp function.
*/
-struct cons_pointer make_function( struct cons_pointer meta,
- struct cons_pointer ( *executable ) ( struct
- stack_frame
- *,
- struct
- cons_pointer,
- struct
- cons_pointer ) )
-{
+struct cons_pointer
+make_function( struct cons_pointer meta, struct cons_pointer ( *executable )
+ ( struct stack_frame *,
+ struct cons_pointer, struct cons_pointer ) ) {
struct cons_pointer pointer = allocate_cell( FUNCTIONTV );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( meta );
@@ -304,6 +238,8 @@ struct cons_pointer make_lambda( struct cons_pointer args,
struct cons_pointer pointer = allocate_cell( LAMBDATV );
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( args );
inc_ref( body );
cell->payload.lambda.args = args;
@@ -320,6 +256,8 @@ struct cons_pointer make_nlambda( struct cons_pointer args,
struct cons_pointer body ) {
struct cons_pointer pointer = allocate_cell( NLAMBDATV );
+ 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 */
+
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( args );
inc_ref( body );
@@ -331,13 +269,13 @@ struct cons_pointer make_nlambda( struct cons_pointer args,
/**
* Return a hash value for this string like thing.
- *
+ *
* What's important here is that two strings with the same characters in the
* same order should have the same hash value, even if one was created using
- * `"foobar"` and the other by `(append "foo" "bar")`. I *think* this function
- * has that property. I doubt that it's the most efficient hash function to
+ * `"foobar"` and the other by `(append "foo" "bar")`. I *think* this function
+ * has that property. I doubt that it's the most efficient hash function to
* have that property.
- *
+ *
* returns 0 for things which are not string like.
*/
uint32_t calculate_hash( wint_t c, struct cons_pointer ptr ) {
@@ -351,9 +289,8 @@ uint32_t calculate_hash( wint_t c, struct cons_pointer ptr ) {
if ( nilp( cell->payload.string.cdr ) ) {
result = ( uint32_t ) c;
} else {
- result =
- ( ( uint32_t ) c *
- cell->payload.string.hash ) & 0xffffffff;
+ result = ( ( uint32_t ) c *
+ cell->payload.string.hash ) & 0xffffffff;
}
break;
}
@@ -367,24 +304,27 @@ uint32_t calculate_hash( wint_t c, struct cons_pointer ptr ) {
* has one character and a pointer to the next; in the last cell the
* pointer to next is NIL.
*/
-struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail,
- uint32_t tag ) {
+struct cons_pointer
+make_string_like_thing( wint_t c, struct cons_pointer tail, uint32_t tag ) {
struct cons_pointer pointer = NIL;
if ( check_tag( tail, tag ) || check_tag( tail, NILTV ) ) {
pointer = allocate_cell( tag );
struct cons_space_object *cell = &pointer2cell( pointer );
+ inc_ref( tail );
cell->payload.string.character = c;
- cell->payload.string.cdr = tail;
+ cell->payload.string.cdr.page = tail.page;
+ /* \todo There's a problem here. Sometimes the offsets on
+ * strings are quite massively off. Fix is probably
+ * cell->payload.string.cdr = tail */
+ cell->payload.string.cdr.offset = tail.offset;
cell->payload.string.hash = calculate_hash( c, tail );
- debug_dump_object( pointer, DEBUG_ALLOC );
- debug_println( DEBUG_ALLOC );
} else {
// \todo should throw an exception!
debug_printf( DEBUG_ALLOC,
- L"Warning: only %4.4s can be prepended to %4.4s\n",
+ L"Warning: only NIL and %4.4s can be prepended to %4.4s\n",
tag, tag );
}
@@ -413,25 +353,16 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) {
*/
struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail,
uint32_t tag ) {
- struct cons_pointer result;
+ struct cons_pointer result = make_string_like_thing( c, tail, tag );
- if ( tag == SYMBOLTV || tag == KEYTV ) {
- result = make_string_like_thing( c, tail, tag );
+ if ( tag == KEYTV ) {
+ struct cons_pointer r = internedp( result, oblist );
- // if ( tag == KEYTV ) {
- // struct cons_pointer r = interned( result, oblist );
-
- // if ( nilp( r ) ) {
- // intern( result, oblist );
- // } else {
- // result = r;
- // }
- // }
- } else {
- result =
- make_exception( c_string_to_lisp_string
- ( L"Unexpected tag when making symbol or key." ),
- NIL );
+ if ( nilp( r ) ) {
+ intern( result, oblist );
+ } else {
+ result = r;
+ }
}
return result;
@@ -440,16 +371,10 @@ struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail,
/**
* Construct a cell which points to an executable Lisp special form.
*/
-struct cons_pointer make_special( struct cons_pointer meta,
- struct cons_pointer ( *executable ) ( struct
- stack_frame
- *frame,
- struct
- cons_pointer,
- struct
- cons_pointer
- env ) )
-{
+struct cons_pointer
+make_special( struct cons_pointer meta, struct cons_pointer ( *executable )
+ ( struct stack_frame * frame,
+ struct cons_pointer, struct cons_pointer env ) ) {
struct cons_pointer pointer = allocate_cell( SPECIALTV );
struct cons_space_object *cell = &pointer2cell( pointer );
inc_ref( meta );
@@ -466,7 +391,7 @@ struct cons_pointer make_special( struct cons_pointer meta,
* @param metadata a pointer to an associaton containing metadata on the stream.
* @return a pointer to the new read stream.
*/
-struct cons_pointer make_read_stream( URL_FILE *input,
+struct cons_pointer make_read_stream( URL_FILE * input,
struct cons_pointer metadata ) {
struct cons_pointer pointer = allocate_cell( READTV );
struct cons_space_object *cell = &pointer2cell( pointer );
@@ -483,7 +408,7 @@ struct cons_pointer make_read_stream( URL_FILE *input,
* @param metadata a pointer to an associaton containing metadata on the stream.
* @return a pointer to the new read stream.
*/
-struct cons_pointer make_write_stream( URL_FILE *output,
+struct cons_pointer make_write_stream( URL_FILE * output,
struct cons_pointer metadata ) {
struct cons_pointer pointer = allocate_cell( WRITETV );
struct cons_space_object *cell = &pointer2cell( pointer );
@@ -495,8 +420,8 @@ struct cons_pointer make_write_stream( URL_FILE *output,
}
/**
- * Return a lisp keyword representation of this wide character string. In
- * keywords, I am accepting only lower case characters and numbers.
+ * Return a lisp keyword representation of this wide character string. In keywords,
+ * I am accepting only lower case characters and numbers.
*/
struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) {
struct cons_pointer result = NIL;
diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h
index 9653402..7c3a390 100644
--- a/src/memory/consspaceobject.h
+++ b/src/memory/consspaceobject.h
@@ -56,24 +56,6 @@
*/
#define EXCEPTIONTV 1346721861
-/**
- * Keywords used when constructing exceptions: `:location`. Instantiated in
- * `init.c`.
- */
-extern struct cons_pointer privileged_keyword_location;
-
-/**
- * Keywords used when constructing exceptions: `:payload`. Instantiated in
- * `init.c`.
- */
-extern struct cons_pointer privileged_keyword_payload;
-
-/**
- * Keywords used when constructing exceptions: `:cause`. Instantiated in
- * `init.c`.
- */
-extern struct cons_pointer privileged_keyword_cause;
-
/**
* An unallocated cell on the free list - should never be encountered by a Lisp
* function.
@@ -139,30 +121,6 @@ extern struct cons_pointer privileged_keyword_cause;
*/
#define LOOPTV 1347374924
-/**
- * @brief Tag for a lazy cons cell.
- *
- * A lazy cons cell is like a cons cell, but lazy.
- *
- */
-#define LAZYCONSTAG "LZYC"
-
-/**
- * @brief Tag for a lazy string cell.
- *
- * A lazy string cell is like a string cell, but lazy.
- *
- */
-#define LAZYSTRTAG "LZYS"
-
-/**
- * @brief Tag for a lazy worker cell.
- *
- * A lazy
- *
- */
-#define LAZYWRKRTAG "WRKR"
-
/**
* The special cons cell at address {0,0} whose car and cdr both point to
* itself.
@@ -207,7 +165,7 @@ extern struct cons_pointer privileged_keyword_cause;
#define READTV 1145128274
/**
- * A real number, represented internally as an IEEE 754-2008 `binary128`.
+ * A real number, represented internally as an IEEE 754-2008 `binary64`.
*/
#define REALTAG "REAL"
@@ -239,7 +197,7 @@ extern struct cons_pointer privileged_keyword_cause;
#define STRINGTV 1196577875
/**
- * A symbol is just like a keyword except not self-evaluating.
+ * A symbol is just like a string except not self-evaluating.
*/
#define SYMBOLTAG "SYMB"
@@ -330,11 +288,6 @@ extern struct cons_pointer privileged_keyword_cause;
*/
#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTV))
-/**
- * true if `conspoint` points to an unassigned cell, else false
- */
-#define freep(conspoint) (check_tag(conspoint,FREETV))
-
/**
* true if `conspoint` points to a function cell, else false
*/
@@ -462,8 +415,6 @@ struct stack_frame {
struct cons_pointer function;
/** the number of arguments provided. */
int args;
- /** the depth of the stack below this frame */
- int depth;
};
/**
@@ -527,13 +478,11 @@ struct free_payload {
* 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.
- *
- * \todo Why is this 60, and not 64 bits?
*/
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, or `NIL` if there are no
+ /** the next (more significant) cell in the chain, ir `NIL` if there are no
* more. */
struct cons_pointer more;
};
@@ -730,11 +679,6 @@ struct cons_pointer inc_ref( struct cons_pointer pointer );
struct cons_pointer dec_ref( struct cons_pointer pointer );
-/**
- * given a cons_pointer as argument, return the tag.
- */
-uint32_t get_tag_value( struct cons_pointer pointer );
-
struct cons_pointer c_type( struct cons_pointer pointer );
struct cons_pointer c_car( struct cons_pointer arg );
diff --git a/src/memory/dump.c b/src/memory/dump.c
index 3a83866..2bc5bb0 100644
--- a/src/memory/dump.c
+++ b/src/memory/dump.c
@@ -29,7 +29,7 @@
#include "memory/vectorspace.h"
-void dump_string_cell( URL_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 ) {
@@ -56,7 +56,7 @@ void dump_string_cell( URL_FILE *output, wchar_t *prefix,
/**
* dump the object at this cons_pointer to this output stream.
*/
-void dump_object( URL_FILE *output, struct cons_pointer pointer ) {
+void dump_object( URL_FILE * output, struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
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,
@@ -114,10 +114,10 @@ void dump_object( URL_FILE *output, struct cons_pointer pointer ) {
case RATIOTV:
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 );
+ pointer2cell( cell.payload.ratio.dividend ).payload.
+ integer.value,
+ pointer2cell( cell.payload.ratio.divisor ).payload.
+ integer.value, cell.count );
break;
case READTV:
url_fputws( L"\t\tInput stream; metadata: ", output );
diff --git a/src/memory/dump.h b/src/memory/dump.h
index 0a69626..f8ef75f 100644
--- a/src/memory/dump.h
+++ b/src/memory/dump.h
@@ -19,8 +19,6 @@
#ifndef __dump_h
#define __dump_h
-void dump_string_cell( URL_FILE * output, wchar_t *prefix,
- struct cons_pointer pointer );
void dump_object( URL_FILE * output, struct cons_pointer pointer );
diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c
index eaabca4..5e1db0a 100644
--- a/src/memory/hashmap.c
+++ b/src/memory/hashmap.c
@@ -18,6 +18,81 @@
#include "memory/hashmap.h"
#include "memory/vectorspace.h"
+/**
+ * Return a hash value for the structure indicated by `ptr` such that if
+ * `x`,`y` are two separate structures whose print representation is the same
+ * then `(sxhash x)` and `(sxhash y)` will always be equal.
+ */
+uint32_t sxhash( struct cons_pointer ptr ) {
+ // TODO: Not Yet Implemented
+ /* TODO: should look at the implementation of Common Lisp sxhash?
+ * My current implementation of `print` only addresses URL_FILE
+ * streams. It would be better if it also addressed strings but
+ * currently it doesn't. Creating a print string of the structure
+ * and taking the hash of that would be one simple (but not necessarily
+ * cheap) solution.
+ */
+ /* TODO: sbcl's implementation of `sxhash` is in src/compiler/sxhash.lisp
+ * and is EXTREMELY complex, and essentially has a different dispatch for
+ * every type of object. It's likely we need to do the same.
+ */
+ return 0;
+}
+
+/**
+ * Get the hash value for the cell indicated by this `ptr`; currently only
+ * implemented for string like things and integers.
+ */
+uint32_t get_hash( struct cons_pointer ptr ) {
+ struct cons_space_object *cell = &pointer2cell( ptr );
+ uint32_t result = 0;
+
+ switch ( cell->tag.value ) {
+ case INTEGERTV:
+ /* Note that we're only hashing on the least significant word of an
+ * integer. */
+ result = cell->payload.integer.value & 0xffffffff;
+ break;
+ case KEYTV:
+ case STRINGTV:
+ case SYMBOLTV:
+ result = cell->payload.string.hash;
+ break;
+ case TRUETV:
+ result = 1; // arbitrarily
+ break;
+ default:
+ result = sxhash( ptr );
+ break;
+ }
+
+ return result;
+}
+
+/**
+ * Free the hashmap indicated by this `pointer`.
+ */
+void free_hashmap( struct cons_pointer pointer ) {
+ struct cons_space_object *cell = &pointer2cell( pointer );
+
+ if ( hashmapp( pointer ) ) {
+ struct vector_space_object *vso = cell->payload.vectorp.address;
+
+ dec_ref( vso->payload.hashmap.hash_fn );
+ dec_ref( vso->payload.hashmap.write_acl );
+
+ for ( int i = 0; i < vso->payload.hashmap.n_buckets; i++ ) {
+ if ( !nilp( vso->payload.hashmap.buckets[i] ) ) {
+ debug_printf( DEBUG_ALLOC,
+ L"Decrementing bucket [%d] of hashmap at 0x%lx\n",
+ i, cell->payload.vectorp.address );
+ dec_ref( vso->payload.hashmap.buckets[i] );
+ }
+ }
+ } else {
+ debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" );
+ }
+}
/**
* A lisp function signature conforming wrapper around get_hash, q.v..
@@ -28,6 +103,32 @@ struct cons_pointer lisp_get_hash( struct stack_frame *frame,
return make_integer( get_hash( frame->arg[0] ), NIL );
}
+/**
+ * Make a hashmap with this number of buckets, using this `hash_fn`. If
+ * `hash_fn` is `NIL`, use the standard hash funtion.
+ */
+struct cons_pointer make_hashmap( uint32_t n_buckets,
+ struct cons_pointer hash_fn,
+ struct cons_pointer write_acl ) {
+ struct cons_pointer result = make_vso( HASHTV,
+ ( sizeof( struct cons_pointer ) *
+ ( n_buckets + 2 ) ) +
+ ( sizeof( uint32_t ) * 2 ) );
+
+ struct hashmap_payload *payload =
+ ( struct hashmap_payload * ) &pointer_to_vso( result )->payload;
+
+ payload->hash_fn = inc_ref( hash_fn );
+ payload->write_acl = inc_ref( write_acl );
+
+ payload->n_buckets = n_buckets;
+ for ( int i = 0; i < n_buckets; i++ ) {
+ payload->buckets[i] = NIL;
+ }
+
+ return result;
+}
+
/**
* Lisp funtion of up to four args (all optional), where
*
@@ -54,16 +155,7 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
}
}
if ( frame->args > 1 ) {
- if ( functionp( frame->arg[1] ) ) {
- hash_fn = frame->arg[1];
- } else if ( nilp( frame->arg[1] ) ) {
- /* that's allowed */
- } else {
- result =
- make_exception( c_string_to_lisp_string
- ( L"Second arg to `hashmap`, if passed, must "
- L"be a function or `nil`.`" ), NIL );
- }
+ hash_fn = frame->arg[1];
}
if ( nilp( result ) ) {
@@ -87,8 +179,9 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
&( map->payload ) )->n_buckets;
map->payload.hashmap.buckets[bucket_no] =
- make_cons( make_cons( key, val ),
- map->payload.hashmap.buckets[bucket_no] );
+ inc_ref( make_cons( make_cons( key, val ),
+ map->payload.hashmap.
+ buckets[bucket_no] ) );
}
}
}
@@ -96,6 +189,79 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
return result;
}
+
+
+/**
+ * If this `ptr` is a pointer to a hashmap, return a new identical hashmap;
+ * else return `NIL`. TODO: should return an exception if ptr is not a
+ * readable hashmap.
+ */
+struct cons_pointer clone_hashmap( struct cons_pointer ptr ) {
+ struct cons_pointer result = NIL;
+
+ if ( truep( authorised( ptr, NIL ) ) ) {
+ if ( hashmapp( ptr ) ) {
+ struct vector_space_object *from = pointer_to_vso( ptr );
+
+ if ( from != NULL ) {
+ struct hashmap_payload from_pl = from->payload.hashmap;
+ result =
+ make_hashmap( from_pl.n_buckets, from_pl.hash_fn,
+ from_pl.write_acl );
+ struct vector_space_object *to = pointer_to_vso( result );
+ struct hashmap_payload to_pl = to->payload.hashmap;
+
+ for ( int i = 0; i < to_pl.n_buckets; i++ ) {
+ to_pl.buckets[i] = from_pl.buckets[i];
+ inc_ref( to_pl.buckets[i] );
+ }
+ }
+ }
+ }
+ // TODO: else exception?
+
+ return result;
+}
+
+/**
+ * Store this `val` as the value of this `key` in this hashmap `mapp`. If
+ * current user is authorised to write to this hashmap, modifies the hashmap and
+ * returns it; if not, clones the hashmap, modifies the clone, and returns that.
+ */
+struct cons_pointer hashmap_put( struct cons_pointer mapp,
+ struct cons_pointer key,
+ struct cons_pointer val ) {
+ // TODO: if current user has write access to this hashmap
+ if ( hashmapp( mapp ) && !nilp( key ) ) {
+ struct vector_space_object *map = pointer_to_vso( mapp );
+
+ if ( nilp( authorised( mapp, map->payload.hashmap.write_acl ) ) ) {
+ mapp = clone_hashmap( mapp );
+ map = pointer_to_vso( mapp );
+ }
+ uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets;
+
+ map->payload.hashmap.buckets[bucket_no] =
+ inc_ref( make_cons( make_cons( key, val ),
+ map->payload.hashmap.buckets[bucket_no] ) );
+ }
+
+ return mapp;
+}
+
+struct cons_pointer hashmap_get( struct cons_pointer mapp,
+ struct cons_pointer key ) {
+ struct cons_pointer result = NIL;
+ if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) {
+ struct vector_space_object *map = pointer_to_vso( mapp );
+ uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets;
+
+ result = c_assoc( key, map->payload.hashmap.buckets[bucket_no] );
+ }
+
+ return result;
+}
+
/**
* Expects `frame->arg[1]` to be a hashmap or namespace; `frame->arg[2]` to be
* a string-like-thing (perhaps necessarily a keyword); frame->arg[3] to be
@@ -106,17 +272,35 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
struct cons_pointer lisp_hashmap_put( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
- // TODO: if current user has write access to this hashmap
-
struct cons_pointer mapp = frame->arg[0];
struct cons_pointer key = frame->arg[1];
struct cons_pointer val = frame->arg[2];
- struct cons_pointer result = hashmap_put( mapp, key, val );
- struct cons_space_object *cell = &pointer2cell( result );
- return result;
+ return hashmap_put( mapp, key, val );
+}
- // TODO: else clone and return clone.
+/**
+ * Copy all key/value pairs in this association list `assoc` into this hashmap `mapp`. If
+ * current user is authorised to write to this hashmap, modifies the hashmap and
+ * returns it; if not, clones the hashmap, modifies the clone, and returns that.
+ */
+struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
+ struct cons_pointer assoc ) {
+ // TODO: if current user has write access to this hashmap
+ if ( hashmapp( mapp ) && !nilp( assoc ) ) {
+ struct vector_space_object *map = pointer_to_vso( mapp );
+
+ if ( hashmapp( mapp ) && consp( assoc ) ) {
+ for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair );
+ pair = c_car( assoc ) ) {
+ /* TODO: this is really hammering the memory management system, because
+ * it will make a new lone for every key/value pair added. Fix. */
+ mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) );
+ }
+ }
+ }
+
+ return mapp;
}
/**
@@ -129,13 +313,33 @@ struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame,
return hashmap_put_all( frame->arg[0], frame->arg[1] );
}
+/**
+ * return a flat list of all the keys in the hashmap indicated by `map`.
+ */
+struct cons_pointer hashmap_keys( struct cons_pointer mapp ) {
+ struct cons_pointer result = NIL;
+ if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) ) {
+ struct vector_space_object *map = pointer_to_vso( mapp );
+
+ for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) {
+ for ( struct cons_pointer c = map->payload.hashmap.buckets[i];
+ !nilp( c ); c = c_cdr( c ) ) {
+ result = make_cons( c_car( c_car( c ) ), result );
+ }
+
+ }
+ }
+
+ return result;
+}
+
struct cons_pointer lisp_hashmap_keys( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
return hashmap_keys( frame->arg[0] );
}
-void dump_map( URL_FILE *output, struct cons_pointer pointer ) {
+void dump_map( URL_FILE * output, struct cons_pointer pointer ) {
struct hashmap_payload *payload =
&pointer_to_vso( pointer )->payload.hashmap;
url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets );
diff --git a/src/memory/hashmap.h b/src/memory/hashmap.h
index 05823bb..b6c4a74 100644
--- a/src/memory/hashmap.h
+++ b/src/memory/hashmap.h
@@ -17,11 +17,25 @@
#define DFLT_HASHMAP_BUCKETS 32
+uint32_t get_hash( struct cons_pointer ptr );
+
+void free_hashmap( struct cons_pointer ptr );
+
+void dump_map( URL_FILE * output, struct cons_pointer pointer );
+
+struct cons_pointer hashmap_get( struct cons_pointer mapp,
+ struct cons_pointer key );
+
+struct cons_pointer hashmap_put( struct cons_pointer mapp,
+ struct cons_pointer key,
+ struct cons_pointer val );
struct cons_pointer lisp_get_hash( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
+struct cons_pointer hashmap_keys( struct cons_pointer map );
+
struct cons_pointer lisp_hashmap_put( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
@@ -34,5 +48,8 @@ struct cons_pointer lisp_make_hashmap( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
+struct cons_pointer make_hashmap( uint32_t n_buckets,
+ struct cons_pointer hash_fn,
+ struct cons_pointer write_acl );
#endif
diff --git a/src/memory/lookup3.c b/src/memory/lookup3.c
index 043d703..359cff2 100644
--- a/src/memory/lookup3.c
+++ b/src/memory/lookup3.c
@@ -170,7 +170,7 @@ and these came close:
hashlittle() has to dance around fitting the key bytes into registers.
--------------------------------------------------------------------
*/
-uint32_t hashword( const uint32_t *k, /* the key, an array of uint32_t values */
+uint32_t hashword( const uint32_t * k, /* the key, an array of uint32_t values */
size_t length, /* the length of the key, in uint32_ts */
uint32_t initval ) { /* the previous hash, or an arbitrary value */
uint32_t a, b, c;
@@ -213,10 +213,10 @@ both be initialized with seeds. If you pass in (*pb)==0, the output
(*pc) will be the same as the return value from hashword().
--------------------------------------------------------------------
*/
-void hashword2( const uint32_t *k, /* the key, an array of uint32_t values */
+void hashword2( const uint32_t * k, /* the key, an array of uint32_t values */
size_t length, /* the length of the key, in uint32_ts */
- uint32_t *pc, /* IN: seed OUT: primary hash value */
- uint32_t *pb ) { /* IN: more seed OUT: secondary hash value */
+ uint32_t * pc, /* IN: seed OUT: primary hash value */
+ uint32_t * pb ) { /* IN: more seed OUT: secondary hash value */
uint32_t a, b, c;
/* Set up the internal state */
@@ -538,8 +538,8 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval ) {
*/
void hashlittle2( const void *key, /* the key to hash */
size_t length, /* length of the key */
- uint32_t *pc, /* IN: primary initval, OUT: primary hash */
- uint32_t *pb ) { /* IN: secondary initval, OUT: secondary hash */
+ uint32_t * pc, /* IN: primary initval, OUT: primary hash */
+ uint32_t * pb ) { /* IN: secondary initval, OUT: secondary hash */
uint32_t a, b, c; /* internal state */
union {
const void *ptr;
diff --git a/src/memory/stack.c b/src/memory/stack.c
index 70c07f9..4b70ed1 100644
--- a/src/memory/stack.c
+++ b/src/memory/stack.c
@@ -17,20 +17,14 @@
#include
-#include "debug.h"
-#include "io/print.h"
-#include "memory/conspage.h"
#include "memory/consspaceobject.h"
+#include "memory/conspage.h"
+#include "debug.h"
#include "memory/dump.h"
+#include "ops/lispops.h"
+#include "io/print.h"
#include "memory/stack.h"
#include "memory/vectorspace.h"
-#include "ops/lispops.h"
-
-/**
- * @brief If non-zero, maximum depth of stack.
- *
- */
-uint32_t stack_limit = 0;
/**
* set a register in a stack frame. Alwaye use this to do so,
@@ -74,19 +68,17 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) {
/**
* Make an empty stack frame, and return it.
- *
- * This function does the actual meat of making the frame.
- *
* @param previous the current top-of-stack;
- * @param depth the depth of the new frame.
+ * @param env the environment in which evaluation happens.
* @return the new frame, or NULL if memory is exhausted.
*/
-struct cons_pointer in_make_empty_frame( struct cons_pointer previous,
- uint32_t depth ) {
+struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
debug_print( L"Entering make_empty_frame\n", DEBUG_ALLOC );
struct cons_pointer result =
make_vso( STACKFRAMETV, sizeof( struct stack_frame ) );
+ debug_dump_object( result, DEBUG_ALLOC );
+
if ( !nilp( result ) ) {
struct stack_frame *frame = get_stack_frame( result );
/*
@@ -94,7 +86,6 @@ struct cons_pointer in_make_empty_frame( struct cons_pointer previous,
*/
frame->previous = previous;
- frame->depth = depth;
/*
* clearing the frame with memset would probably be slightly quicker, but
@@ -107,8 +98,6 @@ struct cons_pointer in_make_empty_frame( struct cons_pointer previous,
for ( int i = 0; i < args_in_frame; i++ ) {
frame->arg[i] = NIL;
}
-
- debug_dump_object( result, DEBUG_ALLOC );
}
debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC );
debug_dump_object( result, DEBUG_ALLOC );
@@ -116,37 +105,6 @@ struct cons_pointer in_make_empty_frame( struct cons_pointer previous,
return result;
}
-/**
- * @brief Make an empty stack frame, and return it.
- *
- * This function does the error checking around actual construction.
- *
- * @param previous the current top-of-stack;
- * @param env the environment in which evaluation happens.
- * @return the new frame, or NULL if memory is exhausted.
- */
-struct cons_pointer make_empty_frame( struct cons_pointer previous ) {
- struct cons_pointer result = NIL;
- uint32_t depth =
- ( nilp( previous ) ) ? 0 : ( get_stack_frame( previous ) )->depth + 1;
-
- if ( stack_limit == 0 || stack_limit > depth ) {
- result = in_make_empty_frame( previous, depth );
- } else {
- result =
- make_exception( c_string_to_lisp_string
- ( L"Stack limit exceeded." ), previous );
- }
-
- if ( nilp( result ) ) {
- /* i.e. out of memory */
- result =
- make_exception( privileged_string_memory_exhausted, previous );
- }
-
- return result;
-}
-
/**
* Allocate a new stack frame with its previous pointer set to this value,
* its arguments set up from these args, evaluated in this env.
@@ -161,7 +119,12 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
debug_print( L"Entering make_stack_frame\n", DEBUG_STACK );
struct cons_pointer result = make_empty_frame( previous );
- if ( !exceptionp( result ) ) {
+ if ( nilp( result ) ) {
+ /* i.e. out of memory */
+ result =
+ make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
+ previous );
+ } else {
struct stack_frame *frame = get_stack_frame( result );
while ( frame->args < args_in_frame && consp( args ) ) {
@@ -199,15 +162,12 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous,
env );
frame->more = more;
inc_ref( more );
-
- for ( ; !nilp( args ); args = c_cdr( args ) ) {
- frame->args++;
- }
}
+
}
- debug_print( L"make_stack_frame: returning\n", DEBUG_STACK );
- debug_dump_object( result, DEBUG_STACK );
}
+ debug_print( L"make_stack_frame: returning\n", DEBUG_STACK );
+ debug_dump_object( result, DEBUG_STACK );
return result;
}
@@ -227,7 +187,12 @@ struct cons_pointer make_special_frame( struct cons_pointer previous,
struct cons_pointer result = make_empty_frame( previous );
- if ( !exceptionp( result ) ) {
+ if ( nilp( result ) ) {
+ /* i.e. out of memory */
+ result =
+ make_exception( c_string_to_lisp_string( L"Memory exhausted." ),
+ previous );
+ } else {
struct stack_frame *frame = get_stack_frame( result );
while ( frame->args < args_in_frame && !nilp( args ) ) {
@@ -270,63 +235,24 @@ void free_stack_frame( struct stack_frame *frame ) {
debug_print( L"Leaving free_stack_frame\n", DEBUG_ALLOC );
}
-struct cons_pointer frame_get_previous( struct cons_pointer frame_pointer ) {
- struct stack_frame *frame = get_stack_frame( frame_pointer );
- struct cons_pointer result = NIL;
-
- if ( frame != NULL ) {
- result = frame->previous;
- }
-
- return result;
-}
-
-void dump_frame_context_fragment( URL_FILE *output,
- struct cons_pointer frame_pointer ) {
- struct stack_frame *frame = get_stack_frame( frame_pointer );
-
- if ( frame != NULL ) {
- url_fwprintf( output, L" <= " );
- print( output, frame->arg[0] );
- }
-}
-
-void dump_frame_context( URL_FILE *output, struct cons_pointer frame_pointer,
- int depth ) {
- struct stack_frame *frame = get_stack_frame( frame_pointer );
-
- if ( frame != NULL ) {
- url_fwprintf( output, L"\tContext: " );
-
- int i = 0;
- for ( struct cons_pointer cursor = frame_pointer;
- i++ < depth && !nilp( cursor );
- cursor = frame_get_previous( cursor ) ) {
- dump_frame_context_fragment( output, cursor );
- }
-
- url_fwprintf( output, L"\n" );
- }
-}
/**
* Dump a stackframe to this stream for debugging
* @param output the stream
* @param frame_pointer the pointer to the frame
*/
-void dump_frame( URL_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 ) {
- url_fwprintf( output, L"Stack frame %d with %d arguments:\n",
- frame->depth, frame->args );
- dump_frame_context( output, frame_pointer, 4 );
-
+ 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] );
- url_fwprintf( output, L"Arg %d:\t%4.4s\tcount: %10u\tvalue: ",
- arg, cell.tag.bytes, 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] );
url_fputws( L"\n", output );
@@ -339,7 +265,7 @@ void dump_frame( URL_FILE *output, struct cons_pointer frame_pointer ) {
}
}
-void dump_stack_trace( URL_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.payload );
url_fputws( L"\n", output );
diff --git a/src/memory/stack.h b/src/memory/stack.h
index 111df48..f132c69 100644
--- a/src/memory/stack.h
+++ b/src/memory/stack.h
@@ -21,8 +21,6 @@
#ifndef __psse_stack_h
#define __psse_stack_h
-#include
-
#include "consspaceobject.h"
#include "conspage.h"
@@ -37,8 +35,6 @@
*/
#define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV)
-extern uint32_t stack_limit;
-
void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value );
struct stack_frame *get_stack_frame( struct cons_pointer pointer );
diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c
index 26a23d9..4bbeb51 100644
--- a/src/memory/vectorspace.c
+++ b/src/memory/vectorspace.c
@@ -13,8 +13,6 @@
#include
#include
#include
-
-
/*
* wide characters
*/
@@ -24,11 +22,9 @@
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
#include "debug.h"
-#include "io/io.h"
#include "memory/hashmap.h"
#include "memory/stack.h"
#include "memory/vectorspace.h"
-#include "ops/intern.h"
/**
@@ -88,11 +84,10 @@ struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) {
if ( vso != NULL ) {
memset( vso, 0, padded );
- vso->header.tag.value = tag;
-
debug_printf( DEBUG_ALLOC,
- L"make_vso: written tag '%4.4s' into vso at %p\n",
- vso->header.tag.bytes, vso );
+ L"make_vso: about to write tag '%4.4s' into vso at %p\n",
+ tag, vso );
+ vso->header.tag.value = tag;
result = make_vec_pointer( vso, tag );
debug_dump_object( result, DEBUG_ALLOC );
vso->header.vecp = result;
@@ -126,9 +121,7 @@ struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) {
void free_vso( struct cons_pointer pointer ) {
struct cons_space_object cell = pointer2cell( pointer );
- debug_printf( DEBUG_ALLOC,
- L"About to free vector-space object of type %s at 0x%lx\n",
- ( char * ) cell.payload.vectorp.tag.bytes,
+ 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;
diff --git a/src/ops/equal.c b/src/ops/equal.c
index 296aea6..39d80af 100644
--- a/src/ops/equal.c
+++ b/src/ops/equal.c
@@ -9,17 +9,12 @@
#include
#include
-#include
+#include "memory/conspage.h"
+#include "memory/consspaceobject.h"
#include "arith/integer.h"
#include "arith/peano.h"
#include "arith/ratio.h"
-#include "debug.h"
-#include "memory/conspage.h"
-#include "memory/consspaceobject.h"
-#include "memory/vectorspace.h"
-#include "ops/equal.h"
-#include "ops/intern.h"
/**
* Shallow, and thus cheap, equality: true if these two objects are
@@ -53,295 +48,14 @@ bool end_of_string( struct cons_pointer string ) {
pointer2cell( string ).payload.string.character == '\0';
}
-/**
- * @brief compare two long doubles and returns true if they are the same to
- * within a tolerance of one part in a billion.
- *
- * @param a
- * @param b
- * @return true if `a` and `b` are equal to within one part in a billion.
- * @return false otherwise.
- */
-bool equal_ld_ld( long double a, long double b ) {
- long double fa = fabsl( a );
- long double fb = fabsl( b );
- /* difference of magnitudes */
- long double diff = fabsl( fa - fb );
- /* average magnitude of the two */
- long double av = ( fa > fb ) ? ( fa - diff ) : ( fb - diff );
- /* amount of difference we will tolerate for equality */
- long double tolerance = av * 0.000000001;
-
- bool result = ( fabsl( a - b ) < tolerance );
-
- debug_printf( DEBUG_EQUAL, L"\nequal_ld_ld returning %d\n", result );
-
- return result;
-}
-
-/**
- * @brief Private function, don't use. It depends on its arguments being
- * numbers and doesn't sanity check them.
- *
- * @param a a lisp integer -- if it isn't an integer, things will break.
- * @param b a lisp real -- if it isn't a real, things will break.
- * @return true if the two numbers have equal value.
- * @return false if they don't.
- */
-bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) {
- debug_print( L"\nequal_integer_real: ", DEBUG_ARITH );
- debug_print_object( a, DEBUG_ARITH );
- debug_print( L" = ", DEBUG_ARITH );
- debug_print_object( b, DEBUG_ARITH );
- bool result = false;
- struct cons_space_object *cell_a = &pointer2cell( a );
- struct cons_space_object *cell_b = &pointer2cell( b );
-
- if ( nilp( cell_a->payload.integer.more ) ) {
- result =
- equal_ld_ld( ( long double ) cell_a->payload.integer.value,
- cell_b->payload.real.value );
- } else {
- fwprintf( stderr,
- L"\nequality is not yet implemented for bignums compared to reals." );
- }
-
- debug_printf( DEBUG_ARITH, L"\nequal_integer_real returning %d\n",
- result );
-
- return result;
-}
-
-/**
- * @brief Private function, don't use. It depends on its arguments being
- * numbers and doesn't sanity check them.
- *
- * @param a a lisp integer -- if it isn't an integer, things will break.
- * @param b a lisp number.
- * @return true if the two numbers have equal value.
- * @return false if they don't.
- */
-bool equal_integer_number( struct cons_pointer a, struct cons_pointer b ) {
- debug_print( L"\nequal_integer_number: ", DEBUG_ARITH );
- debug_print_object( a, DEBUG_ARITH );
- debug_print( L" = ", DEBUG_ARITH );
- debug_print_object( b, DEBUG_ARITH );
- bool result = false;
- struct cons_space_object *cell_b = &pointer2cell( b );
-
- switch ( cell_b->tag.value ) {
- case INTEGERTV:
- result = equal_integer_integer( a, b );
- break;
- case REALTV:
- result = equal_integer_real( a, b );
- break;
- case RATIOTV:
- result = false;
- break;
- }
-
- debug_printf( DEBUG_ARITH, L"\nequal_integer_number returning %d\n",
- result );
-
- return result;
-}
-
-/**
- * @brief Private function, don't use. It depends on its arguments being
- * numbers and doesn't sanity check them.
- *
- * @param a a lisp real -- if it isn't an real, things will break.
- * @param b a lisp number.
- * @return true if the two numbers have equal value.
- * @return false if they don't.
- */
-bool equal_real_number( struct cons_pointer a, struct cons_pointer b ) {
- debug_print( L"\nequal_real_number: ", DEBUG_ARITH );
- debug_print_object( a, DEBUG_ARITH );
- debug_print( L" = ", DEBUG_ARITH );
- debug_print_object( b, DEBUG_ARITH );
- bool result = false;
- struct cons_space_object *cell_b = &pointer2cell( b );
-
- switch ( cell_b->tag.value ) {
- case INTEGERTV:
- result = equal_integer_real( b, a );
- break;
- case REALTV:{
- struct cons_space_object *cell_a = &pointer2cell( a );
- result =
- equal_ld_ld( cell_a->payload.real.value,
- cell_b->payload.real.value );
- }
- break;
- case RATIOTV:
- struct cons_space_object *cell_a = &pointer2cell( a );
- result =
- equal_ld_ld( c_ratio_to_ld( b ), cell_a->payload.real.value );
- break;
- }
-
- debug_printf( DEBUG_ARITH, L"\nequal_real_number returning %d\n", result );
-
- return result;
-}
-
-/**
- * @brief Private function, don't use. It depends on its arguments being
- * numbers and doesn't sanity check them.
- *
- * @param a a number
- * @param b a number
- * @return true if the two numbers have equal value.
- * @return false if they don't.
- */
-bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) {
- bool result = eq( a, b );
-
- debug_print( L"\nequal_number_number: ", DEBUG_ARITH );
- debug_print_object( a, DEBUG_ARITH );
- debug_print( L" = ", DEBUG_ARITH );
- debug_print_object( b, DEBUG_ARITH );
-
- if ( !result ) {
- struct cons_space_object *cell_a = &pointer2cell( a );
- struct cons_space_object *cell_b = &pointer2cell( b );
-
- switch ( cell_a->tag.value ) {
- case INTEGERTV:
- result = equal_integer_number( a, b );
- break;
- case REALTV:
- result = equal_real_number( a, b );
- break;
- case RATIOTV:
- switch ( cell_b->tag.value ) {
- case INTEGERTV:
- /* as ratios are simplified by make_ratio, any
- * ratio that would simplify to an integer is an
- * integer, TODO: no longer always true. */
- result = false;
- break;
- case REALTV:
- result = equal_real_number( b, a );
- break;
- case RATIOTV:
- result = equal_ratio_ratio( a, b );
- break;
- /* can't throw an exception from here, but non-numbers
- * shouldn't have been passed in anyway, so no default. */
- }
- break;
- /* can't throw an exception from here, but non-numbers
- * shouldn't have been passed in anyway, so no default. */
- }
- }
-
- debug_printf( DEBUG_ARITH, L"\nequal_number_number returning %d\n",
- result );
-
- return result;
-}
-
-/**
- * @brief equality of two map-like things.
- *
- * The list returned by `keys` on a map-like thing is not sorted, and is not
- * guaranteed always to come out in the same order. So equality is established
- * if:
- * 1. the length of the keys list is the same; and
- * 2. the value of each key in the keys list for map `a` is the same in map `a`
- * and in map `b`.
- *
- * Private function, do not use outside this file, **WILL NOT** work
- * unless both arguments are VECPs.
- *
- * @param a a pointer to a vector space object.
- * @param b another pointer to a vector space object.
- * @return true if the two objects have the same logical structure.
- * @return false otherwise.
- */
-bool equal_map_map( struct cons_pointer a, struct cons_pointer b ) {
- bool result = false;
-
- struct cons_pointer keys_a = hashmap_keys( a );
-
- if ( c_length( keys_a ) == c_length( hashmap_keys( b ) ) ) {
- result = true;
-
- for ( struct cons_pointer i = keys_a; !nilp( i ); i = c_cdr( i ) ) {
- struct cons_pointer key = c_car( i );
- if ( !equal
- ( hashmap_get( a, key, false ),
- hashmap_get( b, key, false ) ) ) {
- result = false;
- break;
- }
- }
- }
-
- return result;
-}
-
-/**
- * @brief equality of two vector-space things.
- *
- * Expensive, but we need to be able to check for equality of at least hashmaps
- * and namespaces.
- *
- * Private function, do not use outside this file, not guaranteed to work
- * unless both arguments are VECPs pointing to map like things.
- *
- * @param a a pointer to a vector space object.
- * @param b another pointer to a vector space object.
- * @return true if the two objects have the same logical structure.
- * @return false otherwise.
- */
-bool equal_vector_vector( struct cons_pointer a, struct cons_pointer b ) {
- bool result = false;
-
- if ( eq( a, b ) ) {
- result = true; // same
- /* there shouldn't ever be two separate VECP cells which point to the
- * same address in vector space, so I don't believe it's worth checking
- * for this.
- */
- } else if ( vectorp( a ) && vectorp( b ) ) {
- struct vector_space_object *va = pointer_to_vso( a );
- struct vector_space_object *vb = pointer_to_vso( b );
-
- /* what we're saying here is that a namespace is not equal to a map,
- * even if they have identical logical structure. Is this right? */
- if ( va->header.tag.value == vb->header.tag.value ) {
- switch ( va->header.tag.value ) {
- case HASHTV:
- case NAMESPACETV:
- result = equal_map_map( a, b );
- break;
- }
- }
- }
- // else can't throw an exception from here but TODO: should log.
-
- return result;
-}
-
/**
* Deep, and thus expensive, equality: true if these two objects have
* identical structure, else false.
*/
bool equal( struct cons_pointer a, struct cons_pointer b ) {
- debug_print( L"\nequal: ", DEBUG_EQUAL );
- debug_print_object( a, DEBUG_EQUAL );
- debug_print( L" = ", DEBUG_EQUAL );
- debug_print_object( b, DEBUG_EQUAL );
+ bool result = eq( a, b );
- bool result = false;
-
- if ( eq( a, b ) ) {
- result = true;
- } else if ( !numberp( a ) && same_type( a, b ) ) {
+ if ( !result && same_type( a, b ) ) {
struct cons_space_object *cell_a = &pointer2cell( a );
struct cons_space_object *cell_b = &pointer2cell( b );
@@ -367,48 +81,39 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
/* TODO: it is not OK to do this on the stack since list-like
* structures can be of indefinite extent. It *must* be done by
* iteration (and even that is problematic) */
- if ( cell_a->payload.string.hash ==
- cell_b->payload.string.hash ) {
- wchar_t a_buff[STRING_SHIPYARD_SIZE],
- b_buff[STRING_SHIPYARD_SIZE];
- uint32_t tag = cell_a->tag.value;
- int i = 0;
-
- memset( a_buff, 0, sizeof( a_buff ) );
- memset( b_buff, 0, sizeof( b_buff ) );
-
- for ( ; ( i < ( STRING_SHIPYARD_SIZE - 1 ) ) && !nilp( a )
- && !nilp( b ); i++ ) {
- a_buff[i] = cell_a->payload.string.character;
- a = c_cdr( a );
- cell_a = &pointer2cell( a );
-
- b_buff[i] = cell_b->payload.string.character;
- b = c_cdr( b );
- cell_b = &pointer2cell( b );
- }
-
-#ifdef DEBUG
- debug_print( L"Comparing '", DEBUG_EQUAL );
- debug_print( a_buff, DEBUG_EQUAL );
- debug_print( L"' to '", DEBUG_EQUAL );
- debug_print( b_buff, DEBUG_EQUAL );
- debug_print( L"'\n", DEBUG_EQUAL );
-#endif
-
- /* OK, now we have wchar string buffers loaded from the objects. We
- * may not have exhausted either string, so the buffers being equal
- * isn't sufficient. So we recurse at least once. */
-
- result = ( wcsncmp( a_buff, b_buff, i ) == 0 )
- && equal( c_cdr( a ), c_cdr( b ) );
- }
+ result =
+ cell_a->payload.string.hash == cell_b->payload.string.hash
+ && cell_a->payload.string.character ==
+ cell_b->payload.string.character
+ &&
+ ( 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 ) ) );
break;
- case VECTORPOINTTV:
- if ( cell_b->tag.value == VECTORPOINTTV ) {
- result = equal_vector_vector( a, b );
- } else {
- result = false;
+ case INTEGERTV:
+ result =
+ ( cell_a->payload.integer.value ==
+ cell_b->payload.integer.value ) &&
+ equal( cell_a->payload.integer.more,
+ cell_b->payload.integer.more );
+ break;
+ case RATIOTV:
+ result = equal_ratio_ratio( a, b );
+ break;
+ case REALTV:
+ {
+ 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 );
+
+ /*
+ * not more different than one part in a million - close enough
+ */
+ result = fabs( num_a - num_b ) < ( max / 1000000.0 );
}
break;
default:
@@ -416,18 +121,20 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) {
break;
}
} else if ( numberp( a ) && numberp( b ) ) {
- result = equal_number_number( a, b );
+ if ( integerp( a ) ) {
+ result = equal_integer_real( a, b );
+ } else if ( integerp( b ) ) {
+ result = equal_integer_real( b, a );
+ }
}
/*
* there's only supposed ever to be one T and one NIL cell, so each
- * should be caught by eq.
- *
+ * should be caught by eq; equality of vector-space objects is a whole
+ * other ball game so we won't deal with it now (and indeed may never).
* I'm not certain what equality means for read and write streams, so
* I'll ignore them, too, for now.
*/
- debug_printf( DEBUG_EQUAL, L"\nequal returning %d\n", result );
-
return result;
}
diff --git a/src/ops/equal.h b/src/ops/equal.h
index 061eb94..1f27104 100644
--- a/src/ops/equal.h
+++ b/src/ops/equal.h
@@ -15,12 +15,6 @@
#ifndef __equal_h
#define __equal_h
-/**
- * size of buffer for assembling strings. Likely to be useful to
- * read, too.
- */
-#define STRING_SHIPYARD_SIZE 1024
-
/**
* Shallow, and thus cheap, equality: true if these two objects are
* the same object, else false.
diff --git a/src/ops/intern.c b/src/ops/intern.c
index bba5ee5..cd80612 100644
--- a/src/ops/intern.c
+++ b/src/ops/intern.c
@@ -18,26 +18,17 @@
*/
#include
-#include
-/*
- * wide characters
- */
-#include
-#include
-#include "authorise.h"
-#include "debug.h"
-#include "io/io.h"
#include "memory/conspage.h"
#include "memory/consspaceobject.h"
-#include "memory/hashmap.h"
+#include "debug.h"
#include "ops/equal.h"
-#include "ops/intern.h"
+#include "memory/hashmap.h"
#include "ops/lispops.h"
// #include "print.h"
/**
- * @brief The global object list/or, to put it differently, the root namespace.
+ * 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
@@ -49,394 +40,46 @@
struct cons_pointer oblist = NIL;
/**
- * @brief the symbol `NIL`, which is special!
- *
+ * Implementation of interned? in C. The final implementation if interned? will
+ * deal with stores which can be association lists or hashtables or hybrids of
+ * the two, but that will almost certainly be implemented in lisp.
+ *
+ * If this key is lexically identical to a key in this store, return the key
+ * from the store (so that later when we want to retrieve a value, an eq test
+ * will work); otherwise return NIL.
*/
-struct cons_pointer privileged_symbol_nil = NIL;
+struct cons_pointer
+internedp( struct cons_pointer key, struct cons_pointer store ) {
+ struct cons_pointer result = NIL;
-/**
- * Return a hash value for the structure indicated by `ptr` such that if
- * `x`,`y` are two separate structures whose print representation is the same
- * then `(sxhash x)` and `(sxhash y)` will always be equal.
- */
-uint32_t sxhash( struct cons_pointer ptr ) {
- // TODO: Not Yet Implemented
- /* TODO: should look at the implementation of Common Lisp sxhash?
- * My current implementation of `print` only addresses URL_FILE
- * streams. It would be better if it also addressed strings but
- * currently it doesn't. Creating a print string of the structure
- * and taking the hash of that would be one simple (but not necessarily
- * cheap) solution.
- */
- /* TODO: sbcl's implementation of `sxhash` is in src/compiler/sxhash.lisp
- * and is EXTREMELY complex, and essentially has a different dispatch for
- * every type of object. It's likely we need to do the same.
- */
- return 0;
-}
+ if ( symbolp( key ) || keywordp( key ) ) {
+ for ( struct cons_pointer next = store;
+ nilp( result ) && consp( next );
+ next = pointer2cell( next ).payload.cons.cdr ) {
+ struct cons_space_object entry =
+ pointer2cell( pointer2cell( next ).payload.cons.car );
-/**
- * Get the hash value for the cell indicated by this `ptr`; currently only
- * implemented for string like things and integers.
- */
-uint32_t get_hash( struct cons_pointer ptr ) {
- struct cons_space_object *cell = &pointer2cell( ptr );
- uint32_t result = 0;
+ debug_print( L"Internedp: checking whether `", DEBUG_BIND );
+ debug_print_object( key, DEBUG_BIND );
+ debug_print( L"` equals `", DEBUG_BIND );
+ debug_print_object( entry.payload.cons.car, DEBUG_BIND );
+ debug_print( L"`\n", DEBUG_BIND );
- switch ( cell->tag.value ) {
- case INTEGERTV:
- /* Note that we're only hashing on the least significant word of an
- * integer. */
- result = cell->payload.integer.value & 0xffffffff;
- break;
- case KEYTV:
- case STRINGTV:
- case SYMBOLTV:
- result = cell->payload.string.hash;
- break;
- case TRUETV:
- result = 1; // arbitrarily
- break;
- default:
- result = sxhash( ptr );
- break;
- }
-
- return result;
-}
-
-/**
- * Free the hashmap indicated by this `pointer`.
- */
-void free_hashmap( struct cons_pointer pointer ) {
- struct cons_space_object *cell = &pointer2cell( pointer );
-
- if ( hashmapp( pointer ) ) {
- struct vector_space_object *vso = cell->payload.vectorp.address;
-
- dec_ref( vso->payload.hashmap.hash_fn );
- dec_ref( vso->payload.hashmap.write_acl );
-
- for ( int i = 0; i < vso->payload.hashmap.n_buckets; i++ ) {
- if ( !nilp( vso->payload.hashmap.buckets[i] ) ) {
- debug_printf( DEBUG_ALLOC,
- L"Decrementing bucket [%d] of hashmap at 0x%lx\n",
- i, cell->payload.vectorp.address );
- dec_ref( vso->payload.hashmap.buckets[i] );
+ if ( equal( key, entry.payload.cons.car ) ) {
+ result = entry.payload.cons.car;
}
}
} else {
- debug_printf( DEBUG_ALLOC, L"Non-hashmap passed to `free_hashmap`\n" );
- }
-}
-
-
-/**
- * Make a hashmap with this number of buckets, using this `hash_fn`. If
- * `hash_fn` is `NIL`, use the standard hash funtion.
- */
-struct cons_pointer make_hashmap( uint32_t n_buckets,
- struct cons_pointer hash_fn,
- struct cons_pointer write_acl ) {
- struct cons_pointer result = make_vso( HASHTV,
- ( sizeof( struct cons_pointer ) *
- ( n_buckets + 2 ) ) +
- ( sizeof( uint32_t ) * 2 ) );
-
- struct hashmap_payload *payload =
- ( struct hashmap_payload * ) &pointer_to_vso( result )->payload;
-
- payload->hash_fn = inc_ref( hash_fn );
- payload->write_acl = inc_ref( write_acl );
-
- payload->n_buckets = n_buckets;
- for ( int i = 0; i < n_buckets; i++ ) {
- payload->buckets[i] = NIL;
+ debug_print( L"`", DEBUG_BIND );
+ debug_print_object( key, DEBUG_BIND );
+ debug_print( L"` is a ", DEBUG_BIND );
+ debug_print_object( c_type( key ), DEBUG_BIND );
+ debug_print( L", not a KEYW or SYMB", DEBUG_BIND );
}
return result;
}
-/**
- * return a flat list of all the keys in the hashmap indicated by `map`.
- */
-struct cons_pointer hashmap_keys( struct cons_pointer mapp ) {
- struct cons_pointer result = NIL;
- if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) ) {
- struct vector_space_object *map = pointer_to_vso( mapp );
-
- for ( int i = 0; i < map->payload.hashmap.n_buckets; i++ ) {
- for ( struct cons_pointer c = map->payload.hashmap.buckets[i];
- !nilp( c ); c = c_cdr( c ) ) {
- result = make_cons( c_car( c_car( c ) ), result );
- }
- }
- }
-
- return result;
-}
-
-/**
- * Copy all key/value pairs in this association list `assoc` into this hashmap `mapp`. If
- * current user is authorised to write to this hashmap, modifies the hashmap and
- * returns it; if not, clones the hashmap, modifies the clone, and returns that.
- */
-struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
- struct cons_pointer assoc ) {
- // TODO: if current user has write access to this hashmap
- if ( hashmapp( mapp ) ) {
- struct vector_space_object *map = pointer_to_vso( mapp );
-
- if ( consp( assoc ) ) {
- for ( struct cons_pointer pair = c_car( assoc ); !nilp( pair );
- pair = c_car( assoc ) ) {
- /* TODO: this is really hammering the memory management system, because
- * it will make a new lone for every key/value pair added. Fix. */
- if ( consp( pair ) ) {
- mapp = hashmap_put( mapp, c_car( pair ), c_cdr( pair ) );
- } else if ( hashmapp( pair ) ) {
- hashmap_put_all( mapp, pair );
- } else {
- hashmap_put( mapp, pair, TRUE );
- }
- assoc = c_cdr( assoc );
- }
- } else if ( hashmapp( assoc ) ) {
- for ( struct cons_pointer keys = hashmap_keys( assoc );
- !nilp( keys ); keys = c_cdr( keys ) ) {
- struct cons_pointer key = c_car( keys );
- hashmap_put( mapp, key, hashmap_get( assoc, key, false ) );
- }
- }
- }
-
- return mapp;
-}
-
-/** Get a value from a hashmap.
- *
- * Note that this is here, rather than in memory/hashmap.c, because it is
- * closely tied in with search_store, q.v.
- */
-struct cons_pointer hashmap_get( struct cons_pointer mapp,
- struct cons_pointer key, bool return_key ) {
-#ifdef DEBUG
- debug_print( L"\nhashmap_get: key is `", DEBUG_BIND );
- debug_print_object( key, DEBUG_BIND );
- debug_print( L"`; store of type `", DEBUG_BIND );
- debug_print_object( c_type( mapp ), DEBUG_BIND );
- debug_printf( DEBUG_BIND, L"`; returning `%s`.\n",
- return_key ? "key" : "value" );
-#endif
-
- struct cons_pointer result = NIL;
- if ( hashmapp( mapp ) && truep( authorised( mapp, NIL ) ) && !nilp( key ) ) {
- struct vector_space_object *map = pointer_to_vso( mapp );
- uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets;
-
- result =
- search_store( key, map->payload.hashmap.buckets[bucket_no],
- return_key );
- }
-#ifdef DEBUG
- debug_print( L"\nhashmap_get returning: `", DEBUG_BIND );
- debug_print_object( result, DEBUG_BIND );
- debug_print( L"`\n", DEBUG_BIND );
-#endif
-
- return result;
-}
-
-/**
- * If this `ptr` is a pointer to a hashmap, return a new identical hashmap;
- * else return an exception.
- */
-struct cons_pointer clone_hashmap( struct cons_pointer ptr ) {
- struct cons_pointer result = NIL;
-
- if ( truep( authorised( ptr, NIL ) ) ) {
- if ( hashmapp( ptr ) ) {
- struct vector_space_object const *from = pointer_to_vso( ptr );
-
- if ( from != NULL ) {
- struct hashmap_payload from_pl = from->payload.hashmap;
- result =
- make_hashmap( from_pl.n_buckets, from_pl.hash_fn,
- from_pl.write_acl );
- struct vector_space_object const *to =
- pointer_to_vso( result );
- struct hashmap_payload to_pl = to->payload.hashmap;
-
- for ( int i = 0; i < to_pl.n_buckets; i++ ) {
- to_pl.buckets[i] = from_pl.buckets[i];
- inc_ref( to_pl.buckets[i] );
- }
- }
- }
- } else {
- result =
- make_exception( c_string_to_lisp_string
- ( L"Arg to `clone_hashmap` must "
- L"be a readable hashmap.`" ), NIL );
- }
-
- return result;
-}
-
-/**
- * @brief `(search-store key store return-key?)` Search this `store` for this
- * a key lexically identical to this `key`.
- *
- * If found, then, if `return-key?` is non-nil, return the copy found in the
- * `store`, else return the value associated with it.
- *
- * At this stage the following structures are legal stores:
- * 1. an association list comprising (key . value) dotted pairs;
- * 2. a hashmap;
- * 3. a namespace (which for these purposes is identical to a hashmap);
- * 4. a hybrid list comprising both (key . value) pairs and hashmaps as first
- * level items;
- * 5. such a hybrid list, but where the last CDR pointer is to a hashmap
- * rather than to a cons sell or to `nil`.
- *
- * This is over-complex and type 5 should be disallowed, but it will do for
- * now.
- */
-struct cons_pointer search_store( struct cons_pointer key,
- struct cons_pointer store,
- bool return_key ) {
- struct cons_pointer result = NIL;
-
-#ifdef DEBUG
- debug_print( L"\nsearch_store; key is `", DEBUG_BIND );
- debug_print_object( key, DEBUG_BIND );
- debug_print( L"`; store of type `", DEBUG_BIND );
- debug_print_object( c_type( store ), DEBUG_BIND );
- debug_printf( DEBUG_BIND, L"`; returning `%s`.\n",
- return_key ? "key" : "value" );
-#endif
-
- switch ( get_tag_value( key ) ) {
- case SYMBOLTV:
- case KEYTV:
- struct cons_space_object *store_cell = &pointer2cell( store );
-
- switch ( get_tag_value( store ) ) {
- case CONSTV:
- for ( struct cons_pointer cursor = store;
- nilp( result ) && ( consp( cursor )
- || hashmapp( cursor ) );
- cursor = pointer2cell( cursor ).payload.cons.cdr ) {
- switch ( get_tag_value( cursor ) ) {
- case CONSTV:
- struct cons_pointer entry_ptr =
- c_car( cursor );
-
- switch ( get_tag_value( entry_ptr ) ) {
- case CONSTV:
- if ( equal( key, c_car( entry_ptr ) ) ) {
- result =
- return_key ? c_car( entry_ptr )
- : c_cdr( entry_ptr );
- }
- break;
- case HASHTV:
- case NAMESPACETV:
- // TODO: I think this should be impossible, and we should maybe
- // throw an exception.
- result =
- hashmap_get( entry_ptr, key,
- return_key );
- break;
- default:
- result =
- throw_exception
- ( c_string_to_lisp_symbol
- ( L"search-store (entry)" ),
- make_cons
- ( c_string_to_lisp_string
- ( L"Unexpected store type: " ),
- c_type( c_car( entry_ptr ) ) ),
- NIL );
-
- }
- break;
- case HASHTV:
- case NAMESPACETV:
- debug_print
- ( L"\n\tHashmap as top-level value in list",
- DEBUG_BIND );
- result =
- hashmap_get( cursor, key, return_key );
- break;
- default:
- result =
- throw_exception( c_string_to_lisp_symbol
- ( L"search-store (cursor)" ),
- make_cons
- ( c_string_to_lisp_string
- ( L"Unexpected store type: " ),
- c_type( cursor ) ),
- NIL );
- }
- }
- break;
- case HASHTV:
- case NAMESPACETV:
- result = hashmap_get( store, key, return_key );
- break;
- default:
- result =
- throw_exception( c_string_to_lisp_symbol
- ( L"search-store (store)" ),
- make_cons( c_string_to_lisp_string
- ( L"Unexpected store type: " ),
- c_type( store ) ), NIL );
- break;
- }
- break;
- case EXCEPTIONTV:
- result =
- throw_exception( c_string_to_lisp_symbol
- ( L"search-store (exception)" ),
- make_cons( c_string_to_lisp_string
- ( L"Unexpected key type: " ),
- c_type( key ) ), NIL );
-
- break;
- default:
- result =
- throw_exception( c_string_to_lisp_symbol
- ( L"search-store (key)" ),
- make_cons( c_string_to_lisp_string
- ( L"Unexpected key type: " ),
- c_type( key ) ), NIL );
- }
-
- debug_print( L"search-store: returning `", DEBUG_BIND );
- debug_print_object( result, DEBUG_BIND );
- debug_print( L"`\n", DEBUG_BIND );
-
- return result;
-}
-
-struct cons_pointer interned( struct cons_pointer key,
- struct cons_pointer store ) {
- return search_store( key, store, true );
-}
-
-/**
- * @brief Implementation of `interned?` in C: predicate wrapped around interned.
- *
- * @param key the key to search for.
- * @param store the store to search in.
- * @return struct cons_pointer `t` if the key was found, else `nil`.
- */
-struct cons_pointer internedp( struct cons_pointer key,
- struct cons_pointer store ) {
- return nilp( interned( key, store ) ) ? NIL : TRUE;
-}
-
/**
* Implementation of assoc in C. Like interned?, the final implementation will
* deal with stores which can be association lists or hashtables or hybrids of
@@ -447,87 +90,114 @@ struct cons_pointer internedp( struct cons_pointer key,
*/
struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer store ) {
- return search_store( key, store, false );
-}
+ struct cons_pointer result = NIL;
-/**
- * Store this `val` as the value of this `key` in this hashmap `mapp`. If
- * current user is authorised to write to this hashmap, modifies the hashmap and
- * returns it; if not, clones the hashmap, modifies the clone, and returns that.
- */
-struct cons_pointer hashmap_put( struct cons_pointer mapp,
- struct cons_pointer key,
- struct cons_pointer val ) {
- if ( hashmapp( mapp ) && !nilp( key ) ) {
- struct vector_space_object *map = pointer_to_vso( mapp );
+ debug_print( L"c_assoc; key is `", DEBUG_BIND );
+ debug_print_object( key, DEBUG_BIND );
+ debug_print( L"`\n", DEBUG_BIND );
- if ( nilp( authorised( mapp, map->payload.hashmap.write_acl ) ) ) {
- mapp = clone_hashmap( mapp );
- map = pointer_to_vso( mapp );
+ if ( consp( store ) ) {
+ for ( struct cons_pointer next = store;
+ nilp( result ) && ( consp( next ) || hashmapp( next ) );
+ next = pointer2cell( next ).payload.cons.cdr ) {
+ if ( consp( next ) ) {
+ struct cons_pointer entry_ptr = c_car( next );
+ struct cons_space_object entry = pointer2cell( entry_ptr );
+
+ switch ( entry.tag.value ) {
+ case CONSTV:
+ if ( equal( key, entry.payload.cons.car ) ) {
+ result = entry.payload.cons.cdr;
+ }
+ break;
+ case VECTORPOINTTV:
+ result = hashmap_get( entry_ptr, key );
+ break;
+ default:
+ throw_exception( c_string_to_lisp_string
+ ( L"Store entry is of unknown type" ),
+ NIL );
+ }
+ }
}
- uint32_t bucket_no = get_hash( key ) % map->payload.hashmap.n_buckets;
-
- // TODO: if there are too many values in the bucket, rehash the whole
- // hashmap to a bigger number of buckets, and return that.
-
- map->payload.hashmap.buckets[bucket_no] =
- make_cons( make_cons( key, val ),
- map->payload.hashmap.buckets[bucket_no] );
+ } else if ( hashmapp( store ) ) {
+ result = hashmap_get( store, key );
+ } else if ( !nilp( store ) ) {
+ result =
+ throw_exception( c_string_to_lisp_string
+ ( L"Store is of unknown type" ), NIL );
}
- debug_print( L"hashmap_put:\n", DEBUG_BIND );
- debug_dump_object( mapp, DEBUG_BIND );
+ debug_print( L"c_assoc returning ", DEBUG_BIND );
+ debug_print_object( result, DEBUG_BIND );
+ debug_println( DEBUG_BIND );
- return mapp;
+ return result;
}
-/**
- * If this store is modifiable, add this key value pair to it. Otherwise,
- * return a new key/value store containing all the key/value pairs in this
- * store with this key/value pair added to the front.
- */
+ /**
+ * 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 set( struct cons_pointer key, struct cons_pointer value,
struct cons_pointer store ) {
struct cons_pointer result = NIL;
-#ifdef DEBUG
- bool deep = eq( store, oblist );
- debug_print_binding( key, value, deep, DEBUG_BIND );
+ debug_print( L"set: binding `", DEBUG_BIND );
+ debug_print_object( key, DEBUG_BIND );
+ debug_print( L"` to `", DEBUG_BIND );
+ debug_print_object( value, DEBUG_BIND );
+ debug_print( L"` in store ", DEBUG_BIND );
+ debug_dump_object( store, DEBUG_BIND );
+ debug_println( DEBUG_BIND );
- if ( deep ) {
- debug_printf( DEBUG_BIND, L"\t-> %4.4s\n",
- pointer2cell( store ).payload.vectorp.tag.bytes );
- }
-#endif
if ( nilp( store ) || consp( store ) ) {
result = make_cons( make_cons( key, value ), store );
} else if ( hashmapp( store ) ) {
result = hashmap_put( store, key, value );
}
+ debug_print( L"set returning ", DEBUG_BIND );
+ debug_print_object( result, DEBUG_BIND );
+ debug_println( DEBUG_BIND );
+
return result;
}
/**
- * @brief Binds this `key` to this `value` in the global oblist, and returns the `key`.
+ * 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 ) {
debug_print( L"Entering deep_bind\n", DEBUG_BIND );
+ struct cons_pointer old = oblist;
+
+ debug_print( L"deep_bind: binding `", DEBUG_BIND );
+ debug_print_object( key, DEBUG_BIND );
+ debug_print( L"` to ", DEBUG_BIND );
+ debug_print_object( value, DEBUG_BIND );
+ debug_println( DEBUG_BIND );
oblist = set( key, value, oblist );
+ if ( consp( oblist ) ) {
+ inc_ref( oblist );
+ dec_ref( old );
+ }
+
debug_print( L"deep_bind returning ", DEBUG_BIND );
- debug_print_object( key, DEBUG_BIND );
+ debug_print_object( oblist, DEBUG_BIND );
debug_println( DEBUG_BIND );
- return key;
+ return oblist;
}
/**
* 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 TRUE.
+ * with the value NIL.
*/
struct cons_pointer
intern( struct cons_pointer key, struct cons_pointer environment ) {
@@ -535,9 +205,9 @@ intern( struct cons_pointer key, struct cons_pointer environment ) {
struct cons_pointer canonical = internedp( key, environment );
if ( nilp( canonical ) ) {
/*
- * not currently bound. TODO: this should bind to NIL?
+ * not currently bound
*/
- result = set( key, TRUE, environment );
+ result = set( key, NIL, environment );
}
return result;
diff --git a/src/ops/intern.h b/src/ops/intern.h
index 18fc084..fa17563 100644
--- a/src/ops/intern.h
+++ b/src/ops/intern.h
@@ -20,51 +20,14 @@
#ifndef __intern_h
#define __intern_h
-#include
-
-
-extern struct cons_pointer privileged_symbol_nil;
-
extern struct cons_pointer oblist;
-uint32_t get_hash( struct cons_pointer ptr );
-
-void free_hashmap( struct cons_pointer ptr );
-
-void dump_map( URL_FILE * output, struct cons_pointer pointer );
-
-struct cons_pointer hashmap_get( struct cons_pointer mapp,
- struct cons_pointer key, bool return_key );
-
-struct cons_pointer hashmap_put( struct cons_pointer mapp,
- struct cons_pointer key,
- struct cons_pointer val );
-
-struct cons_pointer hashmap_put_all( struct cons_pointer mapp,
- struct cons_pointer assoc );
-
-struct cons_pointer hashmap_keys( struct cons_pointer map );
-
-struct cons_pointer make_hashmap( uint32_t n_buckets,
- struct cons_pointer hash_fn,
- struct cons_pointer write_acl );
-
-struct cons_pointer search_store( struct cons_pointer key,
- struct cons_pointer store, bool return_key );
-
struct cons_pointer c_assoc( struct cons_pointer key,
struct cons_pointer store );
-struct cons_pointer interned( struct cons_pointer key,
- struct cons_pointer environment );
-
struct cons_pointer internedp( struct cons_pointer key,
struct cons_pointer environment );
-struct cons_pointer hashmap_put( struct cons_pointer mapp,
- struct cons_pointer key,
- struct cons_pointer val );
-
struct cons_pointer set( struct cons_pointer key,
struct cons_pointer value,
struct cons_pointer store );
diff --git a/src/ops/lispops.c b/src/ops/lispops.c
index 57b2f8e..f9fb95a 100644
--- a/src/ops/lispops.c
+++ b/src/ops/lispops.c
@@ -24,27 +24,19 @@
#include
#include
-#include "arith/integer.h"
-#include "arith/peano.h"
-#include "debug.h"
-#include "io/io.h"
-#include "io/print.h"
-#include "io/read.h"
-#include "memory/conspage.h"
#include "memory/consspaceobject.h"
-#include "memory/stack.h"
-#include "memory/vectorspace.h"
+#include "memory/conspage.h"
+#include "debug.h"
#include "memory/dump.h"
#include "ops/equal.h"
+#include "arith/integer.h"
#include "ops/intern.h"
+#include "io/io.h"
#include "ops/lispops.h"
-
-/**
- * @brief the name of the symbol to which the prompt is bound;
- *
- * Set in init to `*prompt*`
- */
-struct cons_pointer prompt_name;
+#include "io/print.h"
+#include "io/read.h"
+#include "memory/stack.h"
+#include "memory/vectorspace.h"
/*
* also to create in this section:
@@ -54,6 +46,7 @@ struct cons_pointer prompt_name;
* and others I haven't thought of yet.
*/
+
/**
* Useful building block; evaluate this single form in the context of this
* parent stack frame and this environment.
@@ -75,6 +68,7 @@ struct cons_pointer eval_form( struct stack_frame *parent,
/* things which evaluate to themselves */
case EXCEPTIONTV:
case FREETV: // shouldn't happen, but anyway...
+ // FUNCTIONTV, LAMBDATV, NLAMBDATV, SPECIALTV ?
case INTEGERTV:
case KEYTV:
case LOOPTV: // don't think this should happen...
@@ -85,36 +79,32 @@ struct cons_pointer eval_form( struct stack_frame *parent,
case STRINGTV:
case TIMETV:
case TRUETV:
+ // case VECTORPOINTTV: ?
case WRITETV:
break;
default:
{
struct cons_pointer next_pointer =
make_empty_frame( parent_pointer );
- // inc_ref( next_pointer );
- if ( exceptionp( next_pointer ) ) {
- result = next_pointer;
- } else {
- struct stack_frame *next = get_stack_frame( next_pointer );
- set_reg( next, 0, form );
- next->args = 1;
+ inc_ref( next_pointer );
- result = lisp_eval( next, next_pointer, env );
+ struct stack_frame *next = get_stack_frame( next_pointer );
+ set_reg( next, 0, form );
+ next->args = 1;
- if ( !exceptionp( result ) ) {
- /* if we're returning an exception, we should NOT free the
- * stack frame. Corollary is, when we free an exception, we
- * should free all the frames it's holding on to. */
- dec_ref( next_pointer );
- }
+ result = lisp_eval( next, next_pointer, env );
+
+ if ( !exceptionp( result ) ) {
+ /* if we're returning an exception, we should NOT free the
+ * stack frame. Corollary is, when we free an exception, we
+ * should free all the frames it's holding on to. */
+ dec_ref( next_pointer );
}
}
break;
}
- debug_print( L"eval_form ", DEBUG_EVAL );
- debug_print_object( form, DEBUG_EVAL );
- debug_print( L" returning: ", DEBUG_EVAL );
+ debug_print( L"eval_form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL );
debug_println( DEBUG_EVAL );
@@ -246,22 +236,26 @@ lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer,
return make_nlambda( frame->arg[0], compose_body( frame ) );
}
+void log_binding( struct cons_pointer name, struct cons_pointer val ) {
+ debug_print( L"\n\tBinding ", DEBUG_ALLOC );
+ debug_dump_object( name, DEBUG_ALLOC );
+ debug_print( L" to ", DEBUG_ALLOC );
+ debug_dump_object( val, DEBUG_ALLOC );
+}
/**
* Evaluate a lambda or nlambda expression.
*/
struct cons_pointer
-eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
+eval_lambda( struct cons_space_object cell, struct stack_frame *frame,
struct cons_pointer frame_pointer, struct cons_pointer env ) {
struct cons_pointer result = NIL;
-#ifdef DEBUG
debug_print( L"eval_lambda called\n", DEBUG_LAMBDA );
debug_println( DEBUG_LAMBDA );
-#endif
struct cons_pointer new_env = env;
- struct cons_pointer names = cell->payload.lambda.args;
- struct cons_pointer body = cell->payload.lambda.body;
+ struct cons_pointer names = cell.payload.lambda.args;
+ struct cons_pointer body = cell.payload.lambda.body;
if ( consp( names ) ) {
/* if `names` is a list, bind successive items from that list
@@ -271,11 +265,11 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
struct cons_pointer val = frame->arg[i];
new_env = set( name, val, new_env );
- debug_print_binding( name, val, false, DEBUG_BIND );
+ 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. */
} else if ( symbolp( names ) ) {
@@ -296,7 +290,7 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
}
new_env = set( names, vals, new_env );
-// inc_ref( new_env );
+ inc_ref( new_env );
}
while ( !nilp( body ) ) {
@@ -305,15 +299,12 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA );
debug_print_object( sexpr, DEBUG_LAMBDA );
- // debug_print( L"\t env is: ", DEBUG_LAMBDA );
- // debug_print_object( new_env, 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 ) ) {
+ if ( !nilp( result ) )
dec_ref( result );
- }
result = eval_form( frame, frame_pointer, sexpr, new_env );
@@ -322,7 +313,7 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
}
}
- // dec_ref( new_env );
+ dec_ref( new_env );
debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA );
debug_print_object( result, DEBUG_LAMBDA );
@@ -331,56 +322,6 @@ eval_lambda( struct cons_space_object *cell, struct stack_frame *frame,
return result;
}
-/**
- * if `r` is an exception, and it doesn't have a location, fix up its location from
- * the name associated with this fn_pointer, if any.
- */
-struct cons_pointer maybe_fixup_exception_location( struct cons_pointer r,
- struct cons_pointer
- fn_pointer ) {
- struct cons_pointer result = r;
-
- if ( exceptionp( result )
- && ( functionp( fn_pointer ) || specialp( fn_pointer ) ) ) {
- struct cons_space_object *fn_cell = &pointer2cell( fn_pointer );
-
- struct cons_pointer payload =
- pointer2cell( result ).payload.exception.payload;
- /* TODO: should name_key also be a privileged keyword? */
- struct cons_pointer name_key = c_string_to_lisp_keyword( L"name" );
-
- switch ( get_tag_value( payload ) ) {
- case NILTV:
- case CONSTV:
- case HASHTV:
- {
- if ( nilp( c_assoc( privileged_keyword_location,
- payload ) ) ) {
- pointer2cell( result ).payload.exception.payload =
- set( privileged_keyword_location,
- c_assoc( name_key,
- fn_cell->payload.function.meta ),
- payload );
- }
- }
- break;
- default:
- pointer2cell( result ).payload.exception.payload =
- make_cons( make_cons( privileged_keyword_location,
- c_assoc( name_key,
- fn_cell->payload.function.
- meta ) ),
- make_cons( make_cons
- ( privileged_keyword_payload,
- payload ), NIL ) );
- }
-
- dec_ref( name_key );
- }
-
- return result;
-}
-
/**
* Internal guts of apply.
@@ -401,10 +342,10 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
if ( exceptionp( fn_pointer ) ) {
result = fn_pointer;
} else {
- struct cons_space_object *fn_cell = &pointer2cell( fn_pointer );
+ struct cons_space_object fn_cell = pointer2cell( fn_pointer );
struct cons_pointer args = c_cdr( frame->arg[0] );
- switch ( get_tag_value( fn_pointer ) ) {
+ switch ( fn_cell.tag.value ) {
case EXCEPTIONTV:
/* just pass exceptions straight back */
result = fn_pointer;
@@ -415,19 +356,17 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer exep = NIL;
struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env );
-// inc_ref( next_pointer );
+ inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
struct stack_frame *next =
get_stack_frame( next_pointer );
- result = maybe_fixup_exception_location( ( *
- ( fn_cell->payload.function.executable ) )
- ( next,
- next_pointer,
- env ),
- fn_pointer );
+ result =
+ ( *fn_cell.payload.function.executable ) ( next,
+ next_pointer,
+ env );
dec_ref( next_pointer );
}
}
@@ -446,7 +385,7 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer exep = NIL;
struct cons_pointer next_pointer =
make_stack_frame( frame_pointer, args, env );
-// inc_ref( next_pointer );
+ inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
@@ -461,21 +400,25 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
}
break;
- case HASHTV:
- /* \todo: if arg[0] is a CONS, treat it as a path */
- result = c_assoc( eval_form( frame,
- frame_pointer,
- c_car( c_cdr
- ( frame->arg
- [0] ) ), env ),
- fn_pointer );
+ case VECTORPOINTTV:
+ switch ( pointer_to_vso( fn_pointer )->header.tag.value ) {
+ case HASHTV:
+ /* \todo: if arg[0] is a CONS, treat it as a path */
+ result = c_assoc( eval_form( frame,
+ frame_pointer,
+ c_car( c_cdr
+ ( frame->arg
+ [0] ) ), env ),
+ fn_pointer );
+ break;
+ }
break;
case NLAMBDATV:
{
struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env );
-// inc_ref( next_pointer );
+ inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
@@ -492,13 +435,14 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
{
struct cons_pointer next_pointer =
make_special_frame( frame_pointer, args, env );
- // inc_ref( next_pointer );
+ inc_ref( next_pointer );
if ( exceptionp( next_pointer ) ) {
result = next_pointer;
} else {
- result = maybe_fixup_exception_location( ( *
- ( fn_cell->payload.special.executable ) )
- ( get_stack_frame( next_pointer ), next_pointer, env ), fn_pointer );
+ result =
+ ( *fn_cell.payload.special.
+ executable ) ( get_stack_frame( next_pointer ),
+ next_pointer, env );
debug_print( L"Special form returning: ", DEBUG_EVAL );
debug_print_object( result, DEBUG_EVAL );
debug_println( DEBUG_EVAL );
@@ -514,16 +458,13 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer,
memset( buffer, '\0', bs );
swprintf( buffer, bs,
L"Unexpected cell with tag %d (%4.4s) in function position",
- fn_cell->tag.value, &( fn_cell->tag.bytes[0] ) );
+ fn_cell.tag.value, &fn_cell.tag.bytes[0] );
struct cons_pointer message =
c_string_to_lisp_string( buffer );
free( buffer );
- result =
- throw_exception( c_string_to_lisp_symbol( L"apply" ),
- message, frame_pointer );
+ result = throw_exception( message, frame_pointer );
}
}
-
}
debug_print( L"c_apply: returning: ", DEBUG_EVAL );
@@ -560,24 +501,23 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
debug_dump_object( frame_pointer, DEBUG_EVAL );
struct cons_pointer result = frame->arg[0];
- struct cons_space_object *cell = &pointer2cell( frame->arg[0] );
+ struct cons_space_object cell = pointer2cell( frame->arg[0] );
- switch ( cell->tag.value ) {
+ switch ( cell.tag.value ) {
case CONSTV:
result = c_apply( frame, frame_pointer, env );
break;
case SYMBOLTV:
{
- struct cons_pointer canonical = interned( frame->arg[0], env );
+ struct cons_pointer canonical =
+ internedp( frame->arg[0], env );
if ( nilp( canonical ) ) {
struct cons_pointer message =
make_cons( c_string_to_lisp_string
( L"Attempt to take value of unbound symbol." ),
frame->arg[0] );
- result =
- throw_exception( c_string_to_lisp_symbol( L"eval" ),
- message, frame_pointer );
+ result = throw_exception( message, frame_pointer );
} else {
result = c_assoc( canonical, env );
inc_ref( result );
@@ -587,8 +527,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer,
/*
* \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;
- * H'mmm... this is working, but it isn't here. Where is it?
+ * an s-expression is a good one and I should adopt it;
*/
default:
result = frame->arg[0];
@@ -678,8 +617,7 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = frame->arg[1];
} else {
result =
- throw_exception( c_string_to_lisp_symbol( L"set" ),
- make_cons
+ throw_exception( make_cons
( c_string_to_lisp_string
( L"The first argument to `set` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ),
@@ -718,8 +656,7 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer,
result = val;
} else {
result =
- throw_exception( c_string_to_lisp_symbol( L"set!" ),
- make_cons
+ throw_exception( make_cons
( c_string_to_lisp_string
( L"The first argument to `set!` is not a symbol: " ),
make_cons( frame->arg[0], NIL ) ),
@@ -744,8 +681,6 @@ bool end_of_stringp( struct cons_pointer arg ) {
* 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.
- *
- * Thus: `(cons "a" "bcd") -> "abcd"`, but `(cons "ab" "cd") -> ("ab" . "cd")`
*
* * (cons a b)
*
@@ -765,6 +700,7 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer,
return NIL;
} else if ( stringp( car ) && stringp( 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 {
@@ -791,25 +727,24 @@ 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] );
+ struct cons_space_object cell = pointer2cell( frame->arg[0] );
- switch ( cell->tag.value ) {
+ switch ( cell.tag.value ) {
case CONSTV:
- result = cell->payload.cons.car;
+ result = cell.payload.cons.car;
break;
case NILTV:
break;
case READTV:
result =
- make_string( url_fgetwc( cell->payload.stream.stream ), NIL );
+ make_string( url_fgetwc( cell.payload.stream.stream ), NIL );
break;
case STRINGTV:
- result = make_string( cell->payload.string.character, NIL );
+ result = make_string( cell.payload.string.character, NIL );
break;
default:
result =
- throw_exception( c_string_to_lisp_symbol( L"car" ),
- c_string_to_lisp_string
+ throw_exception( c_string_to_lisp_string
( L"Attempt to take CAR of non sequence" ),
frame_pointer );
}
@@ -836,25 +771,24 @@ 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] );
+ struct cons_space_object cell = pointer2cell( frame->arg[0] );
- switch ( cell->tag.value ) {
+ switch ( cell.tag.value ) {
case CONSTV:
- result = cell->payload.cons.cdr;
+ result = cell.payload.cons.cdr;
break;
case NILTV:
break;
case READTV:
- url_fgetwc( cell->payload.stream.stream );
+ url_fgetwc( cell.payload.stream.stream );
result = frame->arg[0];
break;
case STRINGTV:
- result = cell->payload.string.cdr;
+ result = cell.payload.string.cdr;
break;
default:
result =
- throw_exception( c_string_to_lisp_symbol( L"cdr" ),
- c_string_to_lisp_string
+ throw_exception( c_string_to_lisp_string
( L"Attempt to take CDR of non sequence" ),
frame_pointer );
}
@@ -892,35 +826,7 @@ struct cons_pointer lisp_length( struct stack_frame *frame,
struct cons_pointer
lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
- return c_assoc( frame->arg[0],
- nilp( frame->arg[1] ) ? oblist : frame->arg[1] );
-}
-
-/**
- * @brief `(interned? key store)`: Return `t` if the symbol or keyword `key` is bound in this `store`, else `nil`.
- *
- * @param frame
- * @param frame_pointer
- * @param env
- * @return struct cons_pointer
- */
-struct cons_pointer
-lisp_internedp( struct stack_frame *frame, struct cons_pointer frame_pointer,
- struct cons_pointer env ) {
- struct cons_pointer result = internedp( frame->arg[0],
- nilp( frame->arg[1] ) ? oblist :
- frame->arg[1] );
-
- if ( exceptionp( result ) ) {
- struct cons_pointer old = result;
- struct cons_space_object *cell = &( pointer2cell( result ) );
- result =
- throw_exception( c_string_to_lisp_symbol( L"interned?" ),
- cell->payload.exception.payload, frame_pointer );
- dec_ref( old );
- }
-
- return result;
+ return c_assoc( frame->arg[0], frame->arg[1] );
}
struct cons_pointer c_keys( struct cons_pointer store ) {
@@ -956,15 +862,7 @@ struct cons_pointer lisp_keys( struct stack_frame *frame,
struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
- struct cons_pointer result = TRUE;
-
- if ( frame->args > 1 ) {
- for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) {
- result = eq( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL;
- }
- }
-
- return result;
+ return eq( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
}
/**
@@ -980,54 +878,7 @@ struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer
lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
- struct cons_pointer result = TRUE;
-
- if ( frame->args > 1 ) {
- for ( int b = 1; ( truep( result ) ) && ( b < frame->args ); b++ ) {
- result =
- equal( frame->arg[0], fetch_arg( frame, b ) ) ? TRUE : NIL;
- }
- }
-
- return result;
-}
-
-long int c_count( struct cons_pointer p ) {
- struct cons_space_object *cell = &pointer2cell( p );
- int result = 0;
-
- switch ( cell->tag.value ) {
- case CONSTV:
- case STRINGTV:
- /* I think doctrine is that you cannot treat symbols or keywords as
- * sequences, although internally, of course, they are. Integers are
- * also internally sequences, but also should not be treated as such.
- */
- for ( p; !nilp( p ); p = c_cdr( p ) ) {
- result++;
- }
- }
-
- return result;
-}
-
-/**
- * Function: return the number of top level forms in the object which is
- * the first (and only) argument, if it is a sequence (which for current
- * purposes means a list or a string)
- *
- * * (count l)
- *
- * @param frame my stack_frame.
- * @param frame_pointer a pointer to my stack_frame.
- * @param env my environment (ignored).
- * @return the number of top level forms in a list, or characters in a
- * string, else 0.
- */
-struct cons_pointer
-lisp_count( struct stack_frame *frame, struct cons_pointer frame_pointer,
- struct cons_pointer env ) {
- return acquire_integer( c_count( frame->arg[0] ), NIL );
+ return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL;
}
/**
@@ -1055,15 +906,11 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer,
frame->arg[0] : get_default_stream( true, env );
if ( readp( in_stream ) ) {
- debug_print( L"lisp_read: setting input stream\n",
- DEBUG_IO | DEBUG_REPL );
+ 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 {
- /* should not happen, but has done. */
- debug_print( L"WARNING: invalid input stream; defaulting!\n",
- DEBUG_IO | DEBUG_REPL );
input = file_to_url_file( stdin );
}
@@ -1168,6 +1015,54 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame,
return result;
}
+/**
+ * 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 (from which the stream may be extracted).
+ * @return NIL.
+ */
+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;
+ 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( stderr );
+ }
+
+ debug_print( L"lisp_print: about to print\n", DEBUG_IO );
+ debug_dump_object( frame->arg[0], DEBUG_IO );
+
+ result = print( output, frame->arg[0] );
+
+ 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.
@@ -1241,51 +1136,6 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer,
return result;
}
-/**
- * @brief evaluate a single cond clause; if the test part succeeds return a
- * pair whose car is TRUE and whose cdr is the value of the action part
- */
-struct cons_pointer eval_cond_clause( struct cons_pointer clause,
- struct stack_frame *frame,
- struct cons_pointer frame_pointer,
- struct cons_pointer env ) {
- struct cons_pointer result = NIL;
-
-#ifdef DEBUG
- debug_print( L"\n\tCond clause: ", DEBUG_EVAL );
- debug_print_object( clause, DEBUG_EVAL );
- debug_println( DEBUG_EVAL );
-#endif
-
- if ( consp( clause ) ) {
- struct cons_pointer val =
- eval_form( frame, frame_pointer, c_car( clause ),
- env );
-
- if ( !nilp( val ) ) {
- result =
- make_cons( TRUE,
- c_progn( frame, frame_pointer, c_cdr( clause ),
- env ) );
-
-#ifdef DEBUG
- debug_print( L"\n\t\tclause succeeded; returning: ", DEBUG_EVAL );
- debug_print_object( result, DEBUG_EVAL );
- debug_println( DEBUG_EVAL );
- } else {
- debug_print( L"\n\t\tclause failed.\n", DEBUG_EVAL );
-#endif
- }
- } else {
- result = throw_exception( c_string_to_lisp_symbol( L"cond" ),
- c_string_to_lisp_string
- ( L"Arguments to `cond` must be lists" ),
- frame_pointer );
- }
-
- return result;
-}
-
/**
* 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
@@ -1305,78 +1155,37 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer result = NIL;
bool done = false;
- for ( int i = 0; ( i < frame->args ) && !done; i++ ) {
- struct cons_pointer clause_pointer = fetch_arg( frame, i );
+ for ( int i = 0; i < args_in_frame && !done; i++ ) {
+ struct cons_pointer clause_pointer = frame->arg[i];
+ debug_print( L"Cond clause: ", DEBUG_EVAL );
+ debug_dump_object( clause_pointer, DEBUG_EVAL );
- result = eval_cond_clause( clause_pointer, frame, frame_pointer, env );
+ if ( consp( clause_pointer ) ) {
+ struct cons_space_object cell = pointer2cell( clause_pointer );
+ result =
+ eval_form( frame, frame_pointer, c_car( clause_pointer ),
+ env );
- if ( !nilp( result ) && truep( c_car( result ) ) ) {
- result = c_cdr( result );
+ if ( !nilp( result ) ) {
+ result =
+ c_progn( frame, frame_pointer, c_cdr( clause_pointer ),
+ env );
+ done = true;
+ }
+ } else if ( nilp( clause_pointer ) ) {
done = true;
- break;
+ } else {
+ result = throw_exception( c_string_to_lisp_string
+ ( L"Arguments to `cond` must be lists" ),
+ frame_pointer );
}
}
-#ifdef DEBUG
- debug_print( L"\tCond returning: ", DEBUG_EVAL );
- debug_print_object( result, DEBUG_EVAL );
- debug_println( DEBUG_EVAL );
-#endif
+ /* \todo if there are more than 8 clauses we need to continue into the
+ * remainder */
return result;
}
-/**
- * Throw an exception with a cause.
- * `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
- * lisp function; but it is nevertheless to be preferred to make_exception. A
- * real `throw_exception`, which does, will be needed.
- * object pointing to it. Then this should become a normal lisp function
- * which expects a normally bound frame and environment, such that
- * frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space
- * pointer to the frame in which the exception occurred.
- */
-struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
- struct cons_pointer message,
- struct cons_pointer cause,
- struct cons_pointer
- frame_pointer ) {
- struct cons_pointer result = NIL;
-
-#ifdef DEBUG
- debug_print( L"\nERROR: `", 511 );
- debug_print_object( message, 511 );
- debug_print( L"` at `", 511 );
- debug_print_object( location, 511 );
- debug_print( L"`\n", 511 );
- if ( !nilp( cause ) ) {
- debug_print( L"\tCaused by: ", 511 );
- debug_print_object( cause, 511 );
- debug_print( L"`\n", 511 );
- }
-#endif
- struct cons_space_object *cell = &pointer2cell( message );
-
- if ( cell->tag.value == EXCEPTIONTV ) {
- result = message;
- } else {
- result =
- make_exception( make_cons
- ( make_cons( privileged_keyword_location,
- location ),
- make_cons( make_cons
- ( privileged_keyword_payload,
- message ),
- ( nilp( cause ) ? NIL :
- make_cons( make_cons
- ( privileged_keyword_cause,
- cause ), NIL ) ) ) ),
- frame_pointer );
- }
-
- return result;
-
-}
-
/**
* Throw an exception.
* `throw_exception` is a misnomer, because it doesn't obey the calling signature of a
@@ -1384,14 +1193,25 @@ struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
* real `throw_exception`, which does, will be needed.
* object pointing to it. Then this should become a normal lisp function
* which expects a normally bound frame and environment, such that
- * frame->arg[0] is the payload, frame->arg[1] is the cause, and frame->arg[2] is the cons-space
+ * frame->arg[0] is the message, and frame->arg[1] is the cons-space
* pointer to the frame in which the exception occurred.
*/
struct cons_pointer
-throw_exception( struct cons_pointer location,
- struct cons_pointer payload,
+throw_exception( struct cons_pointer message,
struct cons_pointer frame_pointer ) {
- return throw_exception_with_cause( location, payload, NIL, frame_pointer );
+ debug_print( L"\nERROR: ", DEBUG_EVAL );
+ debug_dump_object( message, DEBUG_EVAL );
+ struct cons_pointer result = NIL;
+
+ struct cons_space_object cell = pointer2cell( message );
+
+ if ( cell.tag.value == EXCEPTIONTV ) {
+ result = message;
+ } else {
+ result = make_exception( message, frame_pointer );
+ }
+
+ return result;
}
/**
@@ -1401,7 +1221,7 @@ throw_exception( struct cons_pointer location,
* normally return. A function which detects a problem it cannot resolve
* *should* return an exception.
*
- * * (exception message location)
+ * * (exception message frame)
*
* @param frame my stack frame.
* @param frame_pointer a pointer to my stack_frame.
@@ -1416,10 +1236,8 @@ struct cons_pointer
lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer message = frame->arg[0];
-
- return exceptionp( message ) ? message :
- throw_exception_with_cause( message, frame->arg[1], frame->arg[2],
- frame->previous );
+ return exceptionp( message ) ? message : throw_exception( message,
+ frame->previous );
}
/**
@@ -1438,47 +1256,36 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
struct cons_pointer expr = NIL;
-
-#ifdef DEBUG
- debug_print( L"Entering new inner REPL\n\tenv is `", DEBUG_REPL );
- debug_print_object( env, DEBUG_REPL );
- debug_print( L"`\n", DEBUG_REPL );
-#endif
+
+ debug_printf(DEBUG_REPL, L"Entering new inner REPL\n");
struct cons_pointer input = get_default_stream( true, env );
struct cons_pointer output = get_default_stream( false, env );
+ 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 );
- if ( truep( frame->arg[0] ) ) {
- new_env = set( prompt_name, frame->arg[0], new_env );
+ if (truep(frame->arg[0])) {
+ new_env = set( prompt_name, frame->arg[0], new_env);
}
- if ( readp( frame->arg[1] ) ) {
- new_env =
- set( c_string_to_lisp_symbol( L"*in*" ), frame->arg[1], new_env );
+ if (readp(frame->arg[1])) {
+ new_env = set( c_string_to_lisp_symbol(L"*in*"), frame->arg[1], new_env);
input = frame->arg[1];
}
- if ( writep( frame->arg[2] ) ) {
- new_env =
- set( c_string_to_lisp_symbol( L"*out*" ), frame->arg[2], new_env );
+ if (readp(frame->arg[2])) {
+ new_env = set( c_string_to_lisp_symbol(L"*out*"), frame->arg[2], new_env);
output = frame->arg[2];
}
-
+
inc_ref( input );
inc_ref( output );
inc_ref( prompt_name );
- /* output should NEVER BE nil; but during development it has happened.
- * To allow debugging under such circumstances, we need an emergency
- * default. */
- URL_FILE *os =
- !writep( output ) ? file_to_url_file( stdout ) :
- pointer2cell( output ).payload.stream.stream;
- if ( !writep( output ) ) {
- debug_print( L"WARNING: invalid output; defaulting!\n",
- DEBUG_IO | DEBUG_REPL );
- }
+ URL_FILE *os = pointer2cell( output ).payload.stream.stream;
+
/* \todo this is subtly wrong. If we were evaluating
* (print (eval (read)))
* then the stack frame for read would have the stack frame for
@@ -1494,10 +1301,7 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
* \todo the whole process of resolving symbol values needs to be revisited
* when we get onto namespaces. */
/* OK, there's something even more subtle here if the root namespace is a map.
- * H'mmmm...
- * I think that now the oblist is a hashmap masquerading as a namespace,
- * we should no longer have to do this. TODO: test, and if so, delete this
- * statement. */
+ * H'mmmm... */
if ( !eq( oblist, old_oblist ) ) {
struct cons_pointer cursor = oblist;
@@ -1526,11 +1330,11 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
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 */
- dec_ref( expr );
break;
}
@@ -1541,16 +1345,13 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
dec_ref( expr );
}
- if ( nilp( output ) ) {
- free( os );
- }
dec_ref( input );
dec_ref( output );
dec_ref( prompt_name );
- dec_ref( new_env );
-
- debug_printf( DEBUG_REPL, L"Leaving inner repl\n" );
+ dec_ref( env );
+ debug_printf(DEBUG_REPL, L"Leaving inner repl\n");
+
return expr;
}
@@ -1570,24 +1371,24 @@ 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] );
+ struct cons_space_object cell = pointer2cell( frame->arg[0] );
struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" );
- switch ( cell->tag.value ) {
+ switch ( cell.tag.value ) {
case FUNCTIONTV:
- result = c_assoc( source_key, cell->payload.function.meta );
+ result = c_assoc( source_key, cell.payload.function.meta );
break;
case SPECIALTV:
- result = c_assoc( source_key, cell->payload.special.meta );
+ result = c_assoc( source_key, cell.payload.special.meta );
break;
case LAMBDATV:
result = make_cons( c_string_to_lisp_symbol( L"lambda" ),
- make_cons( cell->payload.lambda.args,
- cell->payload.lambda.body ) );
+ 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 ) );
+ make_cons( cell.payload.lambda.args,
+ cell.payload.lambda.body ) );
break;
}
// \todo suffers from premature GC, and I can't see why!
@@ -1610,8 +1411,7 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) {
c_append( c_cdr( l1 ), l2 ) );
}
} else {
- throw_exception( c_string_to_lisp_symbol( L"append" ),
- c_string_to_lisp_string
+ throw_exception( c_string_to_lisp_string
( L"Can't append: not same type" ), NIL );
}
break;
@@ -1621,26 +1421,23 @@ struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) {
if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) {
if ( nilp( c_cdr( l1 ) ) ) {
return
- make_string_like_thing( ( pointer2cell( l1 ).
- payload.string.character ),
- l2,
+ make_string_like_thing( ( pointer2cell( l1 ).payload.
+ string.character ), l2,
pointer2cell( l1 ).tag.value );
} else {
return
- make_string_like_thing( ( pointer2cell( l1 ).
- payload.string.character ),
+ make_string_like_thing( ( pointer2cell( l1 ).payload.
+ string.character ),
c_append( c_cdr( l1 ), l2 ),
pointer2cell( l1 ).tag.value );
}
} else {
- throw_exception( c_string_to_lisp_symbol( L"append" ),
- c_string_to_lisp_string
+ throw_exception( c_string_to_lisp_string
( L"Can't append: not same type" ), NIL );
}
break;
default:
- throw_exception( c_string_to_lisp_symbol( L"append" ),
- c_string_to_lisp_string
+ throw_exception( c_string_to_lisp_string
( L"Can't append: not a sequence" ), NIL );
break;
}
@@ -1703,14 +1500,6 @@ struct cons_pointer lisp_mapcar( struct stack_frame *frame,
return result;
}
-/**
- * @brief construct and return a list of arbitrarily many arguments.
- *
- * @param frame The stack frame.
- * @param frame_pointer A pointer to the stack frame.
- * @param env The evaluation environment.
- * @return struct cons_pointer a pointer to the result
- */
struct cons_pointer lisp_list( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env ) {
@@ -1724,8 +1513,6 @@ struct cons_pointer lisp_list( struct stack_frame *frame,
return result;
}
-
-
/**
* Special form: evaluate a series of forms in an environment in which
* these bindings are bound.
@@ -1743,25 +1530,21 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
struct cons_pointer symbol = c_car( pair );
if ( symbolp( symbol ) ) {
- struct cons_pointer val =
- eval_form( frame, frame_pointer, c_cdr( pair ),
- bindings );
+ bindings =
+ make_cons( make_cons
+ ( symbol,
+ eval_form( frame, frame_pointer, c_cdr( pair ),
+ bindings ) ), bindings );
- debug_print_binding( symbol, val, false, DEBUG_BIND );
-
- bindings = make_cons( make_cons( symbol, val ), bindings );
} else {
result =
- throw_exception( c_string_to_lisp_symbol( L"let" ),
- c_string_to_lisp_string
+ throw_exception( c_string_to_lisp_string
( L"Let: cannot bind, not a symbol" ),
frame_pointer );
break;
}
}
- debug_print( L"\nlet: bindings complete.\n", DEBUG_BIND );
-
/* i.e., no exception yet */
for ( int form = 1; !exceptionp( result ) && form < frame->args; form++ ) {
result =
@@ -1769,68 +1552,47 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
bindings );
}
- /* release the local bindings as they go out of scope! **BUT**
- * bindings were consed onto the front of env, so caution... */
- // for (struct cons_pointer cursor = bindings; !eq( cursor, env); cursor = c_cdr(cursor)) {
- // dec_ref( cursor);
- // }
-
return result;
}
-/**
- * @brief Boolean `and` of arbitrarily many arguments.
- *
- * @param frame The stack frame.
- * @param frame_pointer A pointer to the stack frame.
- * @param env The evaluation environment.
- * @return struct cons_pointer a pointer to the result
- */
-struct cons_pointer lisp_and( struct stack_frame *frame,
- struct cons_pointer frame_pointer,
- struct cons_pointer env ) {
- bool accumulator = true;
- struct cons_pointer result = frame->more;
+// /**
+// * 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 );
- for ( int a = 0; accumulator == true && a < frame->args; a++ ) {
- accumulator = truthy( fetch_arg( frame, a ) );
- }
-#
- return accumulator ? TRUE : NIL;
-}
+// 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 );
+// }
-/**
- * @brief Boolean `or` of arbitrarily many arguments.
- *
- * @param frame The stack frame.
- * @param frame_pointer A pointer to the stack frame.
- * @param env The evaluation environment.
- * @return struct cons_pointer a pointer to the result
- */
-struct cons_pointer lisp_or( struct stack_frame *frame,
- struct cons_pointer frame_pointer,
- struct cons_pointer env ) {
- bool accumulator = false;
- struct cons_pointer result = frame->more;
+// dump_object( output, frame->arg[0] );
+// url_fputws( L"\n", output );
- for ( int a = 0; accumulator == false && a < frame->args; a++ ) {
- accumulator = truthy( fetch_arg( frame, a ) );
- }
+// if ( writep( out_stream ) ) {
+// dec_ref( out_stream );
+// } else {
+// free( output );
+// }
- return accumulator ? TRUE : NIL;
-}
-
-/**
- * @brief Logical inverese: if the first argument is `nil`, return `t`, else `nil`.
- *
- * @param frame The stack frame.
- * @param frame_pointer A pointer to the stack frame.
- * @param env The evaluation environment.
- * @return struct cons_pointer `t` if the first argument is `nil`, else `nil`.
- */
-struct cons_pointer lisp_not( struct stack_frame *frame,
- struct cons_pointer frame_pointer,
- struct cons_pointer env ) {
- return nilp( frame->arg[0] ) ? TRUE : NIL;
-}
+// return frame->arg[0];
+// }
diff --git a/src/ops/lispops.h b/src/ops/lispops.h
index 66f46c8..da1f27e 100644
--- a/src/ops/lispops.h
+++ b/src/ops/lispops.h
@@ -22,8 +22,6 @@
#ifndef __psse_lispops_h
#define __psse_lispops_h
-extern struct cons_pointer prompt_name;
-
/*
* utilities
*/
@@ -131,15 +129,15 @@ struct cons_pointer lisp_cdr( struct stack_frame *frame,
struct cons_pointer lisp_inspect( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
-struct cons_pointer lisp_internedp( struct stack_frame *frame,
- struct cons_pointer frame_pointer,
- struct cons_pointer env );
struct cons_pointer lisp_eq( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
struct cons_pointer lisp_equal( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
+struct cons_pointer lisp_print( struct stack_frame *frame,
+ struct cons_pointer frame_pointer,
+ struct cons_pointer env );
struct cons_pointer lisp_read( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
@@ -149,9 +147,6 @@ struct cons_pointer lisp_repl( struct stack_frame *frame,
struct cons_pointer lisp_reverse( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
-struct cons_pointer
-lisp_count( struct stack_frame *frame, struct cons_pointer frame_pointer,
- struct cons_pointer env );
/**
* Function: Get the Lisp type of the single argument.
@@ -190,19 +185,13 @@ struct cons_pointer lisp_cond( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
-struct cons_pointer throw_exception_with_cause( struct cons_pointer location,
- struct cons_pointer message,
- struct cons_pointer cause,
- struct cons_pointer
- frame_pointer );
/**
* Throw an exception.
* `throw_exception` is a misnomer, because it doesn't obey the calling
* signature of a lisp function; but it is nevertheless to be preferred to
* make_exception. A real `throw_exception`, which does, will be needed.
*/
-struct cons_pointer throw_exception( struct cons_pointer location,
- struct cons_pointer message,
+struct cons_pointer throw_exception( struct cons_pointer message,
struct cons_pointer frame_pointer );
struct cons_pointer lisp_exception( struct stack_frame *frame,
@@ -234,17 +223,4 @@ struct cons_pointer lisp_let( struct stack_frame *frame,
struct cons_pointer lisp_try( struct stack_frame *frame,
struct cons_pointer frame_pointer,
struct cons_pointer env );
-
-
-struct cons_pointer lisp_and( struct stack_frame *frame,
- struct cons_pointer frame_pointer,
- struct cons_pointer env );
-
-struct cons_pointer lisp_or( struct stack_frame *frame,
- struct cons_pointer frame_pointer,
- struct cons_pointer env );
-
-struct cons_pointer lisp_not( struct stack_frame *frame,
- struct cons_pointer frame_pointer,
- struct cons_pointer env );
#endif
diff --git a/src/repl.c b/src/repl.c
index 8ae0b43..bef08b1 100644
--- a/src/repl.c
+++ b/src/repl.c
@@ -10,7 +10,6 @@
#include
#include
#include
-#include
#include "memory/consspaceobject.h"
#include "debug.h"
@@ -18,20 +17,11 @@
#include "ops/lispops.h"
#include "memory/stack.h"
-/**
- * @brief Handle an interrupt signal.
- *
- * @param dummy
- */
-void int_handler( int dummy ) {
- wprintf( L"TODO: handle ctrl-C in a more interesting way\n" );
-}
/**
* The read/eval/print loop.
*/
void repl( ) {
- signal( SIGINT, int_handler );
debug_print( L"Entered repl\n", DEBUG_REPL );
struct cons_pointer env =
@@ -41,6 +31,8 @@ void repl( ) {
struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, env );
if ( !nilp( frame_pointer ) ) {
+ inc_ref( frame_pointer );
+
lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, env );
dec_ref( frame_pointer );
diff --git a/src/version.h b/src/version.h
index 462f9be..c9e2cf6 100644
--- a/src/version.h
+++ b/src/version.h
@@ -8,4 +8,4 @@
* Licensed under GPL version 2.0, or, at your option, any later version.
*/
-#define VERSION "0.0.6-SNAPSHOT"
+#define VERSION "0.0.5"
diff --git a/state-of-play.md b/state-of-play.md
new file mode 100644
index 0000000..e96a15a
--- /dev/null
+++ b/state-of-play.md
@@ -0,0 +1,46 @@
+# State of Play
+
+## 20250314
+
+Thinking further about this, I think at least part of the problem is that I'm storing bignums as cons-space objects, which means that the integer representation I can store has to fit into the size of a cons pointer, which is 64 bits. Which means that to store integers larger than 64 bits I need chains of these objects.
+
+If I stored bignums in vector space, this problem would go away (especially as I have not implemented vector space yet).
+
+However, having bignums in vector space would cause a churn of non-standard-sized objects in vector space, which would mean much more frequent garbage collection, which has to be mark-and-sweep because unequal-sized objects, otherwise you get heap fragmentation.
+
+So maybe I just have to put more work into debugging my cons-space bignums.
+
+Bother, bother.
+
+There are no perfect solutions.
+
+However however, it's only the node that's short on vector space which has to pause to do a mark and sweep. It doesn't interrupt any other node, because their reference to the object will remain the same, even if it is the 'home node' of the object which is sweeping. So all the node has to do is set its busy flag, do GC, and clear its busy flag, The rest of the system can just be carrying on as normal.
+
+So... maybe mark and sweep isn't the big deal I think it is?
+
+## 20250313
+
+OK, the 60 bit integer cell happens in `int128_to_integer` in `arith/integer.c`. It seems to be being done consistently; but there is no obvious reason. `MAX_INTEGER` is defined in `arith/peano.h`. I've changed both to use 63 bits, and this makes no change to the number of unit tests that fail.
+
+With this change, `(fact 21)`, which was previously printing nothing, now prints a value, `11,891,611,015,076,642,816`. However, this value is definitively wrong, should be `51,090,942,171,709,440,000`. But, I hadn't fixed the shift in `integer_to_string`; have now... still no change in number of failed tests...
+
+But `(fact 21)` gives a different wrong value, `4,974,081,987,435,560,960`. Factorial values returned by `fact` are correct (agree with SBCL running the same code) up to `(fact 20)`, with both 60 bit integer cells and 63 bit integer cells giving correct values.
+
+Uhhhmmm... but I'd missed two other places where I'd had the number of significant bits as a numeric literal. Fixed those and now `(fact 21)` does not return a printable answer at all, although the internal representation is definitely wrong. So we may be seeing why I chose 60 bits.
+
+Bother.
+
+## 20250312
+
+Printing of bignums definitely doesn't work; I'm not persuaded that reading of bignums works right either, and there are probably problems with bignum arithmetic too.
+
+The internal memory representation of a number rolls over from one cell to two cells at 1152921504606846976, and I'm not at all certain why it does because this is neither 263 nor 264.
+
+| | | |
+| -------------- | -------------------- | ---- |
+| 262 | 4611686018427387904 | |
+| 263 | 9223372036854775808 | |
+| 264 | 18446744073709551616 | |
+| Mystery number | 1152921504606846976 | |
+
+In fact, our mystery number turns out (by inspection) to be 260. But **why**?
diff --git a/unit-tests/add.sh b/unit-tests/add.sh
index aab4073..2802c3a 100755
--- a/unit-tests/add.sh
+++ b/unit-tests/add.sh
@@ -1,92 +1,79 @@
#!/bin/bash
-result=0;
-
-echo -n "$0: Add two small integers... "
-
expected='5'
-actual=`echo "(add 2 3)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1`
+actual=`echo "(add 2 3)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-echo -n "$0: Add float to integer... "
-
expected='5.5'
-actual=`echo "(add 2.5 3)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1`
+actual=`echo "(add 2.5 3)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
+ exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-echo -n "$0: Add two rationals... "
-
expected='1/4'
-actual=`echo "(+ 3/14 1/28)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1`
+actual=`echo "(+ 3/14 1/28)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-echo -n "$0: Add an integer to a rational... "
-
# (+ integer ratio) should be ratio
expected='25/4'
-actual=`echo "(+ 6 1/4)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1`
+actual=`echo "(+ 6 1/4)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-echo -n "$0: Add a rational to an integer... "
-
# (+ ratio integer) should be ratio
expected='25/4'
-actual=`echo "(+ 1/4 6)" | target/psse 2>/dev/null | sed -r '/^\s*$/d' | tail -1`
+actual=`echo "(+ 1/4 6)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-echo -n "$0: Add a real to a rational... "
-
# (+ real ratio) should be real
# for this test, trailing zeros can be ignored
expected='6.25'
actual=`echo "(+ 6.000000001 1/4)" |\
target/psse 2> /dev/null |\
- sed -r '/^\s*$/d' |\
- sed 's/0*$//'`
+ sed 's/0*$//' |\
+ head -2 |\
+ tail -1`
outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc`
-if [ "${outcome}" -eq "1" ]
+if [ "${outcome}" = "1" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-exit ${result}
diff --git a/unit-tests/allocation-tests/allocation-tester.sh b/unit-tests/allocation-tests/allocation-tester.sh
deleted file mode 100755
index 5605075..0000000
--- a/unit-tests/allocation-tests/allocation-tester.sh
+++ /dev/null
@@ -1,22 +0,0 @@
-#1/bin/bash
-
-echo "Case, Summary, Allocated, Deallocated, Not deallocated, Delta Allocated, Delta Deallocated, Delta Not Deallocated"
-basecase=`echo '' | ../../target/psse 2>&1 | grep Allocation | tr -d '[:punct:]'`
-bca=`echo ${basecase} | awk '{print $4}'`
-bcd=`echo ${basecase} | awk '{print $6}'`
-bcn=`echo ${basecase} | awk '{print $9}'`
-
-echo "\"Basecase\", \"${basecase}\", ${bca}, ${bcd}, ${bcn}"
-
-while IFS= read -r form; do
- allocation=`echo ${form} | ../../target/psse 2>&1 | grep Allocation | tr -d '[:punct:]'`
- tca=`echo ${allocation} | awk '{print $4}'`
- tcd=`echo ${allocation} | awk '{print $6}'`
- tcn=`echo ${allocation} | awk '{print $9}'`
-
- dca=`echo "${tca} - ${bca}" | bc`
- dcd=`echo "${tcd} - ${bcd}" | bc`
- dcn=`echo "${tcn} - ${bcn}" | bc`
-
- echo "\"${form}\", \"${allocation}\", ${tca}, ${tcd}, ${tcn}, ${dca}, ${dcd}, ${dcn}"
-done
diff --git a/unit-tests/allocation-tests/allocation-tests.csv b/unit-tests/allocation-tests/allocation-tests.csv
deleted file mode 100644
index 902577b..0000000
--- a/unit-tests/allocation-tests/allocation-tests.csv
+++ /dev/null
@@ -1,28 +0,0 @@
-Case, Summary, Allocated, Deallocated, Not deallocated, Delta Allocated, Delta Deallocated, Delta Not Deallocated
-"Basecase", "Allocation summary allocated 19986 deallocated 245 not deallocated 19741", 19986, 245, 19741
-"", "Allocation summary allocated 19986 deallocated 245 not deallocated 19741", 19986, 245, 19741, 0, 0, 0
-"nil", "Allocation summary allocated 20019 deallocated 253 not deallocated 19766", 20019, 253, 19766, 33, 8, 25
-"()", "Allocation summary allocated 19990 deallocated 249 not deallocated 19741", 19990, 249, 19741, 4, 4, 0
-"(quote ())", "Allocation summary allocated 20025 deallocated 247 not deallocated 19778", 20025, 247, 19778, 39, 2, 37
-"(list)", "Allocation summary allocated 20023 deallocated 257 not deallocated 19766", 20023, 257, 19766, 37, 12, 25
-"(list )", "Allocation summary allocated 20023 deallocated 257 not deallocated 19766", 20023, 257, 19766, 37, 12, 25
-"(list 1)", "Allocation summary allocated 20033 deallocated 259 not deallocated 19774", 20033, 259, 19774, 47, 14, 33
-"(list 1 1)", "Allocation summary allocated 20043 deallocated 261 not deallocated 19782", 20043, 261, 19782, 57, 16, 41
-"(list 1 1 1)", "Allocation summary allocated 20053 deallocated 263 not deallocated 19790", 20053, 263, 19790, 67, 18, 49
-"(list 1 2 3)", "Allocation summary allocated 20053 deallocated 263 not deallocated 19790", 20053, 263, 19790, 67, 18, 49
-"(+)", "Allocation summary allocated 20022 deallocated 255 not deallocated 19767", 20022, 255, 19767, 36, 10, 26
-"(+ 1)", "Allocation summary allocated 20030 deallocated 257 not deallocated 19773", 20030, 257, 19773, 44, 12, 32
-"(+ 1 1)", "Allocation summary allocated 20039 deallocated 259 not deallocated 19780", 20039, 259, 19780, 53, 14, 39
-"(+ 1 1 1)", "Allocation summary allocated 20048 deallocated 261 not deallocated 19787", 20048, 261, 19787, 62, 16, 46
-"(+ 1 2 3)", "Allocation summary allocated 20048 deallocated 261 not deallocated 19787", 20048, 261, 19787, 62, 16, 46
-"(list 'a 'a 'a)", "Allocation summary allocated 20137 deallocated 278 not deallocated 19859", 20137, 278, 19859, 151, 33, 118
-"(list 'a 'b 'c)", "Allocation summary allocated 20137 deallocated 278 not deallocated 19859", 20137, 278, 19859, 151, 33, 118
-"(list :a :b :c)", "Allocation summary allocated 20107 deallocated 260 not deallocated 19847", 20107, 260, 19847, 121, 15, 106
-"(list :alpha :bravo :charlie)", "Allocation summary allocated 20471 deallocated 260 not deallocated 20211", 20471, 260, 20211, 485, 15, 470
-"{}", "Allocation summary allocated 19992 deallocated 251 not deallocated 19741", 19992, 251, 19741, 6, 6, 0
-"{:z 0}", "Allocation summary allocated 20029 deallocated 255 not deallocated 19774", 20029, 255, 19774, 43, 10, 33
-"{:zero 0}", "Allocation summary allocated 20107 deallocated 255 not deallocated 19852", 20107, 255, 19852, 121, 10, 111
-"{:z 0 :o 1}", "Allocation summary allocated 20066 deallocated 256 not deallocated 19810", 20066, 256, 19810, 80, 11, 69
-"{:zero 0 :one 1}", "Allocation summary allocated 20196 deallocated 259 not deallocated 19937", 20196, 259, 19937, 210, 14, 196
-"{:z 0 :o 1 :t 2}", "Allocation summary allocated 20103 deallocated 257 not deallocated 19846", 20103, 257, 19846, 117, 12, 105
-"{:zero 0 :one 1 :two 2 :three 3 :four 4 :five five :six 6 :seven 7 :eight 8 :nine 9}", "Allocation summary allocated 21164 deallocated 286 not deallocated 20878", 21164, 286, 20878, 1178, 41, 1137
diff --git a/unit-tests/allocation-tests/test-forms b/unit-tests/allocation-tests/test-forms
deleted file mode 100644
index 6f63893..0000000
--- a/unit-tests/allocation-tests/test-forms
+++ /dev/null
@@ -1,28 +0,0 @@
-
-nil
-()
-(quote ())
-(list)
-(list )
-(list 1)
-(list 1 1)
-(list 1 1 1)
-(list 1 2 3)
-(+)
-(+ 1)
-(+ 1 1)
-(+ 1 1 1)
-(+ 1 2 3)
-(list 'a 'a 'a)
-(list 'a 'b 'c)
-(list :a :b :c)
-(list :aa :bb :cc)
-(list :aaa :bbb :ccc)
-(list :alpha :bravo :charlie)
-{}
-{:z 0}
-{:zero 0}
-{:z 0 :o 1}
-{:zero 0 :one 1}
-{:z 0 :o 1 :t 2}
-{:zero 0 :one 1 :two 2 :three 3 :four 4 :five five :six 6 :seven 7 :eight 8 :nine 9}
diff --git a/unit-tests/append.sh b/unit-tests/append.sh
index 972aa04..0f6fb30 100755
--- a/unit-tests/append.sh
+++ b/unit-tests/append.sh
@@ -1,44 +1,24 @@
#!/bin/bash
-return=0;
-
-echo -n "$0: Append two lists... "
-
expected='(a b c d e f)'
-actual=`echo "(append '(a b c) '(d e f))" | target/psse 2>/dev/null | tail -1`
+actual=`echo "(append '(a b c) '(d e f))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-echo -n "$0: Append two strings... "
-
expected='"hellodere"'
-actual=`echo '(append "hello" "dere")' | target/psse 2>/dev/null | tail -1`
+actual=`echo '(append "hello" "dere")' | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-echo -n "$0: Append keyword to string should error... "
-
-expected='Exception:'
-actual=`echo '(append "hello" :dere)' | target/psse 2>/dev/null | sed -r '/^\s*$/d' | awk '{print $1}'`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
-fi
-
-exit ${return}
\ No newline at end of file
diff --git a/unit-tests/apply.sh b/unit-tests/apply.sh
index aa8171a..811fdae 100755
--- a/unit-tests/apply.sh
+++ b/unit-tests/apply.sh
@@ -1,29 +1,13 @@
#!/bin/bash
-result=1
-
-echo -n "$0: Apply function to one argument... "
expected='1'
-actual=`echo "(apply 'add '(1))"| target/psse 2>/dev/null | tail -1`
+actual=`echo "(apply 'add '(1))"| target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
+ exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-
-echo -n "$0: Apply function to multiple arguments... "
-expected='3'
-actual=`echo "(apply 'add '(1 2))"| target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-exit ${result}
diff --git a/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh
index aa0aef4..7bbb41e 100755
--- a/unit-tests/bignum-add.sh
+++ b/unit-tests/bignum-add.sh
@@ -1,7 +1,5 @@
#!/bin/bash
-return=0
-
#####################################################################
# add two large numbers, not actally bignums to produce a smallnum
# (right on the boundary)
@@ -9,28 +7,28 @@ a=1152921504606846975
b=1
c=`echo "$a + $b" | bc`
expected='t'
-output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>tmp/psse.log`
+output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
tail -1`
-echo -n "$0 => adding $a to $b: "
+echo -n "adding $a to $b: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-echo -n "$0: checking no bignum was created: "
-grep -v 'BIGNUM!' tmp/psse.log > /dev/null
+echo -n "checking no bignum was created: "
+grep -v 'BIGNUM!' psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
#####################################################################
@@ -40,29 +38,29 @@ a='1152921504606846976'
b=1
c=`echo "$a + $b" | bc`
expected='t'
-output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>tmp/psse.log`
+output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
-echo -n "$0 => adding $a to $b: "
+echo -n "adding $a to $b: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-echo -n "$0 => checking a bignum was created: "
-grep 'BIGNUM!' tmp/psse.log > /dev/null
+echo -n "checking a bignum was created: "
+grep 'BIGNUM!' psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
@@ -73,139 +71,93 @@ a='1152921504606846977'
b=1
c=`echo "$a + $b" | bc`
expected='t'
-output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>tmp/psse.log`
+output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
-echo -n "$0 => adding $a to $b: "
+echo -n "adding $a to $b: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-echo -n "$0 => checking a bignum was created: "
-grep 'BIGNUM!' tmp/psse.log > /dev/null
+echo -n "checking a bignum was created: "
+grep 'BIGNUM!' psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
- return=`echo "${return} + 1" | bc`
+ 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>tmp/psse.log`
+output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
-echo -n "$0 => adding $a to $b: "
+echo -n "adding $a to $b: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-echo -n "$0 => checking a bignum was created: "
-grep 'BIGNUM!' tmp/psse.log > /dev/null
+echo -n "checking a bignum was created: "
+grep 'BIGNUM!' psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-#####################################################################
-# add two small bignums to produce a bigger bignum
-
-a=1152921504606846977
-c=`echo "$a + $a" | bc`
-echo -n "$0 => adding $a to $a: "
-expected='t'
-output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>tmp/psse.log`
-
-actual=`echo $output |\
- tail -1 |\
- sed 's/\,//g'`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
-fi
-
-#####################################################################
-# add five small bignums to produce a bigger bignum
-
-a=1152921504606846977
-c=`echo "$a * 5" | bc`
-echo -n "$0 => adding $a, $a $a, $a, $a: "
-expected='t'
-output=`echo "(= (+ $a $a $a $a $a) $c)" | target/psse -v 2 2>tmp/psse.log`
-
-actual=`echo $output |\
- tail -1 |\
- sed 's/\,//g'`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
-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>tmp/psse.log`
+output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
-echo -n "$0 => adding $a to $b: "
+echo -n "adding $a to $b: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-echo -n "$0 => checking a bignum was created: "
-grep 'BIGNUM!' tmp/psse.log > /dev/null
+echo -n "checking a bignum was created: "
+grep 'BIGNUM!' psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
@@ -216,29 +168,29 @@ a=1
b=1329227995784915872903807060280344576
c=`echo "$a + $b" | bc`
expected='t'
-output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>tmp/psse.log`
+output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
-echo -n "$0 => adding $a to $b: "
+echo -n "adding $a to $b: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-echo -n "$0 => checking a bignum was created: "
-grep 'BIGNUM!' tmp/psse.log > /dev/null
+echo -n "checking a bignum was created: "
+grep 'BIGNUM!' psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
@@ -250,29 +202,27 @@ a=1
b=3064991081731777716716694054300618367237478244367204352
c=`echo "$a + $b" | bc`
expected='t'
-output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>tmp/psse.log`
+output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log`
actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
-echo -n "$0 => adding $a to $b: "
+echo -n "adding $a to $b: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-echo -n "$0 => checking a bignum was created: "
-grep 'BIGNUM!' tmp/psse.log > /dev/null
+echo -n "checking a bignum was created: "
+grep 'BIGNUM!' psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-
-exit ${return}
\ No newline at end of file
diff --git a/unit-tests/bignum-expt.sh b/unit-tests/bignum-expt.sh
index aa76af7..ab9cb24 100755
--- a/unit-tests/bignum-expt.sh
+++ b/unit-tests/bignum-expt.sh
@@ -1,13 +1,11 @@
#!/bin/bash
-result=0
-
#####################################################################
# last 'smallnum' value:
# sbcl calculates (expt 2 59) => 576460752303423488
expected='576460752303423488'
-output=`target/psse 2>/dev/null < (expt 2 59): "
+echo -n "(expt 2 59): "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
#####################################################################
@@ -34,7 +32,7 @@ fi
# sbcl calculates (expt 2 60) => 1152921504606846976
expected='1152921504606846976'
-output=`target/psse 2>/dev/null < (expt 2 60): "
+echo -n "(expt 2 60): "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
#####################################################################
@@ -61,7 +59,7 @@ fi
# sbcl calculates (expt 2 61) => 2305843009213693952
expected='2305843009213693952'
-output=`target/psse 2>/dev/null < (expt 2 61): "
+echo -n "(expt 2 61): "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
+
+
# sbcl calculates (expt 2 64) => 18446744073709551616
expected='18446744073709551616'
-output=`target/psse 2>/dev/null < (expt 2 64): "
+echo -n "(expt 2 64): "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
# sbcl calculates (expt 2 65) => 36893488147419103232
expected='36893488147419103232'
-output=`target/psse 2>/dev/null < (expt 2 65): "
+echo -n "(expt 2 65): "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-
-exit ${result}
\ No newline at end of file
+exit 0
diff --git a/unit-tests/bignum-print.sh b/unit-tests/bignum-print.sh
index 2be8032..d556e71 100755
--- a/unit-tests/bignum-print.sh
+++ b/unit-tests/bignum-print.sh
@@ -1,7 +1,5 @@
#!/bin/bash
-return=0
-
#####################################################################
# large number, not actally a bignum
expected='576460752303423488'
@@ -11,13 +9,13 @@ actual=`echo $output |\
sed 's/\,//g' |\
sed 's/[^0-9]*\([0-9]*\).*/\1/'`
-echo -n "$0 => printing $expected: "
+echo -n "printing $expected: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=1
+ exit 1
fi
@@ -30,13 +28,13 @@ actual=`echo $output |\
sed 's/\,//g' |\
sed 's/[^0-9]*\([0-9]*\).*/\1/'`
-echo -n "$0 => printing $expected: "
+echo -n "printing $expected: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=1
+ exit 1
fi
@@ -49,13 +47,13 @@ actual=`echo $output |\
sed 's/\,//g' |\
sed 's/[^0-9]*\([0-9]*\).*/\1/'`
-echo -n "$0 => printing $expected: "
+echo -n "printing $expected: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=1
+ exit 1
fi
@@ -72,13 +70,13 @@ actual=`echo $output |\
sed 's/\,//g' |\
sed 's/[^0-9]*\([0-9]*\).*/\1/'`
-echo -n "$0 => printing $expected: "
+echo -n "printing $expected: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', \n got '${actual}'"
- return=1
+ exit 1
fi
exit 0
@@ -92,13 +90,13 @@ actual=`echo $output |\
sed 's/\,//g' |\
sed 's/[^0-9]*\([0-9]*\).*/\1/'`
-echo -n "$0 => printing $expected: "
+echo -n "printing $expected: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=1
+ exit 1
fi
-exit ${return}
+exit 0
diff --git a/unit-tests/bignum-subtract.sh b/unit-tests/bignum-subtract.sh
index 814d901..9342913 100755
--- a/unit-tests/bignum-subtract.sh
+++ b/unit-tests/bignum-subtract.sh
@@ -1,7 +1,5 @@
#!/bin/bash
-result=0
-
#####################################################################
# subtract a smallnum from a smallnum to produce a smallnum
# (right on the boundary)
@@ -14,23 +12,23 @@ actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
-echo -n "$0 => subtracting $b from $a: "
+echo -n "subtracting $b from $a: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-echo -n "$0 => checking no bignum was created: "
+echo -n "checking no bignum was created: "
grep -v 'BIGNUM!' psse.log > /dev/null
if [ $? -eq "0" ]
then
echo "OK"
else
echo "Fail"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
#####################################################################
@@ -45,13 +43,13 @@ actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
-echo -n "$0 => subtracting $b from $a: "
+echo -n "subtracting $b from $a: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
#####################################################################
@@ -65,13 +63,13 @@ actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
-echo -n "$0 => subtracting $b from $a: "
+echo -n "subtracting $b from $a: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
@@ -87,13 +85,13 @@ actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
-echo -n "$0 => subtracting $b from $a: "
+echo -n "subtracting $b from $a: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
#####################################################################
@@ -107,13 +105,12 @@ actual=`echo $output |\
tail -1 |\
sed 's/\,//g'`
-echo -n "$0 => subtracting $b from $a: "
+echo -n "subtracting $b from $a: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-exit ${result}
\ No newline at end of file
diff --git a/unit-tests/bignum.sh b/unit-tests/bignum.sh
index cec5453..aa29143 100755
--- a/unit-tests/bignum.sh
+++ b/unit-tests/bignum.sh
@@ -1,7 +1,5 @@
#!/bin/bash
-return=0
-
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.
@@ -11,8 +9,6 @@ if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
- echo "$0 => Fail: expected '${expected}', got '${actual}'"
- return=1
+ echo "Fail: expected '${expected}', got '${actual}'"
+ exit 1
fi
-
-exit ${return}
\ No newline at end of file
diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh
index 6a6307b..3e84d79 100755
--- a/unit-tests/complex-list.sh
+++ b/unit-tests/complex-list.sh
@@ -1,7 +1,7 @@
#!/bin/bash
expected='(1 2 3 ("Fred") nil 77,354)'
-actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse 2>/dev/null | tail -1`
+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
index 12552bd..ab2e2f0 100755
--- a/unit-tests/cond.sh
+++ b/unit-tests/cond.sh
@@ -1,31 +1,24 @@
#!/bin/bash
-result=0
-
-echo -n "$0: cond with one clause... "
-
expected='5'
-actual=`echo "(cond ((equal? 2 2) 5))" | target/psse 2>/dev/null | tail -1`
+actual=`echo "(cond ((equal 2 2) 5))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-echo -n "$0: cond with two clauses... "
-
expected='"should"'
-actual=`echo "(cond ((equal? 2 3) \"shouldn't\")(t \"should\"))" | target/psse 2>/dev/null | tail -1`
+actual=`echo "(cond ((equal 2 3) \"shouldn't\")(t \"should\"))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
- else
+ exit 0
+else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-
-exit ${result}
\ No newline at end of file
diff --git a/unit-tests/empty-list.sh b/unit-tests/empty-list.sh
index 2588202..8f0f702 100755
--- a/unit-tests/empty-list.sh
+++ b/unit-tests/empty-list.sh
@@ -7,7 +7,7 @@
#
expected=nil
-actual=`echo "'()" | target/psse 2>/dev/null | 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
index bdd7dfd..a1e5baa 100755
--- 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 | tail -1`
+actual=`echo '""' | target/psse | tail -1`
if [ "$expected" = "$actual" ]
then
diff --git a/unit-tests/equal.sh b/unit-tests/equal.sh
deleted file mode 100644
index 815988b..0000000
--- a/unit-tests/equal.sh
+++ /dev/null
@@ -1,206 +0,0 @@
-#!/bin/bash
-
-# Tests for equality.
-
-result=0
-
-echo -n "$0: integers... "
-
-expected="t"
-actual=`echo "(= 5 5)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: different integers... "
-
-expected="nil"
-actual=`echo "(= 4 5)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-
-echo -n "$0: reals... "
-
-expected="t"
-actual=`echo "(= 5.001 5.001)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-
-echo -n "$0: different reals... "
-
-expected="nil"
-actual=`echo "(= 5.001 5.002)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: ratios... "
-
-expected="t"
-actual=`echo "(= 4/5 4/5)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-
-echo -n "$0: equivalent ratios... "
-
-expected="t"
-actual=`echo "(= 4/5 12/15)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-
-echo -n "$0: different ratios... "
-
-expected="nil"
-actual=`echo "(= 4/5 5/5)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: atoms... "
-
-expected="t"
-actual=`echo "(= 'foo 'foo)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: different atoms... "
-
-expected="nil"
-actual=`echo "(= 'foo 'bar)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: keywords... "
-
-expected="t"
-actual=`echo "(= :foo :foo)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: different keywords... "
-
-expected="nil"
-actual=`echo "(= :foo :bar)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: strings... "
-
-expected="t"
-actual=`echo '(= "foo" "foo")' | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: different strings... "
-
-expected="nil"
-actual=`echo '(= "foo" "bar")' | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: maps... "
-
-expected="t"
-actual=`echo '(= {:foo 1 :bar 2} {:bar 2 :foo 1})' | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: different maps... "
-
-expected="nil"
-actual=`echo '(= {:foo 1 :bar 2} {:bar 1 :foo 2})' | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-exit ${result}
diff --git a/unit-tests/eval-integer.sh b/unit-tests/eval-integer.sh
index 6e93628..1aadb39 100755
--- 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 | 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
index 9b3099d..d83bbe8 100755
--- 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 | tail -1`
+actual=`echo "(eval '(add 2 3))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
@@ -10,4 +10,3 @@ else
echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
- 2>/dev/null
\ No newline at end of file
diff --git a/unit-tests/eval-quote-symbol.sh b/unit-tests/eval-quote-symbol.sh
index 5072fb5..e977461 100755
--- a/unit-tests/eval-quote-symbol.sh
+++ b/unit-tests/eval-quote-symbol.sh
@@ -1,7 +1,7 @@
#!/bin/bash
-expected=''
-actual=`echo "(eval 'cond)" | target/psse 2>/dev/null | 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
index 965d445..3aa16d7 100755
--- a/unit-tests/eval-real.sh
+++ b/unit-tests/eval-real.sh
@@ -3,7 +3,7 @@
# for this test, trailing zeros can be ignored
expected='5.05'
actual=`echo "(eval 5.05)" |\
- target/psse 2>/dev/null |\
+ target/psse 2> /dev/null |\
sed 's/0*$//' |\
tail -1`
diff --git a/unit-tests/eval-string.sh b/unit-tests/eval-string.sh
index 95b987d..90f6f2c 100755
--- 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 | 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
index 82691b6..8e3d513 100755
--- 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 | tail -1`
+actual=`echo ${expected} | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
diff --git a/unit-tests/integer.sh b/unit-tests/integer.sh
index 3a1e542..18ae66e 100755
--- 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 | tail -1`
+actual=`echo ${expected} | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
diff --git a/unit-tests/interpreter.sh b/unit-tests/intepreter.sh
similarity index 85%
rename from unit-tests/interpreter.sh
rename to unit-tests/intepreter.sh
index a9c95bc..6f23fc9 100755
--- a/unit-tests/interpreter.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 | 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/let.sh b/unit-tests/let.sh
index 037a96a..6454b1e 100755
--- a/unit-tests/let.sh
+++ b/unit-tests/let.sh
@@ -1,29 +1,24 @@
#!/bin/bash
-result=0
-
-echo -n "$0: let with two bindings, one form in body..."
expected='11'
-actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse 2>/dev/null | tail -1`
+actual=`echo "(let ((a . 5)(b . 6)) (+ a b))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '$expected', got '$actual'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-echo -n "$0: let with two bindings, two forms in body..."
expected='1'
-actual=`echo "(let ((a . 5)(b . 6)) (+ a b) (- b a))" | target/psse 2>/dev/null | tail -1`
+actual=`echo "(let ((a . 5)(b . 6)) (+ a b) (- b a))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
+ exit 0
else
echo "Fail: expected '$expected', got '$actual'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-
-exit ${result}
\ No newline at end of file
diff --git a/unit-tests/list-test,sh b/unit-tests/list-test,sh
new file mode 100644
index 0000000..32f4797
--- /dev/null
+++ b/unit-tests/list-test,sh
@@ -0,0 +1,38 @@
+#!/bin/bash
+
+expected="(0 1 2 3 4 5 6 7 8 9 a b c d e f)"
+
+actual=`echo "(list 0 1 2 3 4 5 6 7 8 9 'a 'b 'c 'd 'e 'f)" | target/psse | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+ echo "OK"
+else
+ echo "Fail: expected '$expected', got '$actual'"
+ exit 1
+fi
+
+expected="(0 1 2 3 4)"
+
+actual=`echo "(list 0 1 2 3 4)" | target/psse | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+ echo "OK"
+else
+ echo "Fail: expected '$expected', got '$actual'"
+ exit 1
+fi
+
+expected="(0 1 2 3 4 5 6 7)"
+
+actual=`echo "(list 0 1 2 3 4 5 6 7)" | target/psse | tail -1`
+
+if [ "${expected}" = "${actual}" ]
+then
+ echo "OK"
+ exit 0
+else
+ echo "Fail: expected '$expected', got '$actual'"
+ exit 1
+fi
diff --git a/unit-tests/list-test.sh b/unit-tests/list-test.sh
deleted file mode 100644
index ef94631..0000000
--- a/unit-tests/list-test.sh
+++ /dev/null
@@ -1,47 +0,0 @@
-#!/bin/bash
-
-result=0
-
-echo -n "$0: flat list with 16 elements... "
-expected="(0 1 2 3 4 5 6 7 8 9 a b c d e f)"
-
-actual=`echo "(list 0 1 2 3 4 5 6 7 8 9 'a 'b 'c 'd 'e 'f)" |\
- target/psse 2>/dev/null |\
- tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '$expected', got '$actual'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: flat list with 5 elements... "
-expected="(0 1 2 3 4)"
-
-actual=`echo "(list 0 1 2 3 4)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '$expected', got '$actual'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: flat list with 8 elements... "
-expected="(0 1 2 3 4 5 6 7)"
-
-actual=`echo "(list 0 1 2 3 4 5 6 7)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
- exit 0
-else
- echo "Fail: expected '$expected', got '$actual'"
- result=`echo "${result} + 1" | bc`
-fi
-
-exit ${result}
\ No newline at end of file
diff --git a/unit-tests/many-args.sh b/unit-tests/many-args.sh
index bbbb6e8..0317f77 100755
--- a/unit-tests/many-args.sh
+++ b/unit-tests/many-args.sh
@@ -1,30 +1,24 @@
#!/bin/bash
-result=0
-
-echo -n "$0: plus with fifteen arguments... "
-
expected="120"
-actual=`echo "(+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)" | target/psse 2>/dev/null | 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}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-echo -n "$0: check that all the args are actually being evaluated... "
+# 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 2>/dev/null | tail -1`
+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"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-
-exit ${result}
diff --git a/unit-tests/map.sh b/unit-tests/map.sh
index 0e698f0..65dc182 100755
--- a/unit-tests/map.sh
+++ b/unit-tests/map.sh
@@ -1,25 +1,23 @@
#!/bin/bash
-result=0
-
#####################################################################
# Create an empty map using map notation
expected='{}'
-actual=`echo "$expected" | target/psse 2>/dev/null | tail -1`
+actual=`echo "$expected" | target/psse | tail -1`
-echo -n "$0: Empty map using compact map notation... "
+echo -n "Empty map using compact map notation: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=1
+ exit 1
fi
#####################################################################
# Create an empty map using make-map
expected='{}'
-actual=`echo "(hashmap)" | target/psse 2>/dev/null | tail -1`
+actual=`echo "(hashmap)" | target/psse | tail -1`
echo -n "Empty map using (make-map): "
if [ "${expected}" = "${actual}" ]
@@ -27,7 +25,7 @@ then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=1
+ exit 1
fi
#####################################################################
@@ -35,15 +33,15 @@ fi
# significant at this stage, but in the long term should be sorted
# alphanumerically
expected='{:one 1, :two 2, :three 3}'
-actual=`echo "{:one 1 :two 2 :three 3}" | target/psse 2>/dev/null | tail -1`
+actual=`echo "{:one 1 :two 2 :three 3}" | target/psse | tail -1`
-echo -n "$0: Map using map notation... "
+echo -n "Map using map notation: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=1
+ exit 1
fi
#####################################################################
@@ -51,45 +49,42 @@ fi
# significant at this stage, but in the long term should be sorted
# alphanumerically
expected='{:one 1, :two 2, :three 3}'
-actual=`echo "(hashmap nil nil '((:one . 1)(:two . 2)(:three . 3)))" |\
- target/psse 2>/dev/null | tail -1`
+actual=`echo "(hashmap nil nil '((:one . 1)(:two . 2)(:three . 3)))" | target/psse | tail -1`
-echo -n "$0: Map using (hashmap) with arguments... "
+echo -n "Map using (hashmap): "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=1
+ exit 1
fi
#####################################################################
# Keyword in function position
expected='2'
-actual=`echo "(:two {:one 1 :two 2 :three 3})" | target/psse 2>/dev/null | tail -1`
+actual=`echo "(:two {:one 1 :two 2 :three 3})" | target/psse | tail -1`
-echo -n "$0: Keyword in function position... "
+echo -n "Keyword in function position: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=1
+ exit 1
fi
#####################################################################
# Map in function position
expected='2'
-actual=`echo "({:one 1 :two 2 :three 3} :two)" | target/psse 2>/dev/null | tail -1`
+actual=`echo "({:one 1 :two 2 :three 3} :two)" | target/psse | tail -1`
-echo -n "$0: Map in function position... "
+echo -n "Map in function position: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=1
+ exit 1
fi
-
-exit ${result}
\ No newline at end of file
diff --git a/unit-tests/memory.sh b/unit-tests/memory.sh
deleted file mode 100644
index 1bb76f6..0000000
--- a/unit-tests/memory.sh
+++ /dev/null
@@ -1,14 +0,0 @@
-#!/bin/bash
-
-actual=`echo "" | target/psse 2>&1 | tail -2`
-
-alloc=`echo $actual | sed 's/[[:punct:]]/ /g' | awk '{print $4}'`
-dealloc=`echo $actual | sed 's/[[:punct:]]/ /g' | awk '{print $6}'`
-
-if [ "${alloc}" = "${dealloc}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${alloc}', got '${dealloc}'"
- exit 1
-fi
diff --git a/unit-tests/multiply.sh b/unit-tests/multiply.sh
index 1e2da1f..94b19f6 100755
--- a/unit-tests/multiply.sh
+++ b/unit-tests/multiply.sh
@@ -1,31 +1,24 @@
#!/bin/bash
-result=0
-
-echo -n "$0: multiply two integers... "
-
expected='6'
-actual=`echo "(multiply 2 3)" | target/psse 2>/dev/null | tail -1`
+actual=`echo "(multiply 2 3)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-echo -n "$0: multiply a real by an integer... "
-
expected='7.5'
-actual=`echo "(multiply 2.5 3)" | target/psse 2>/dev/null | tail -1`
+actual=`echo "(multiply 2.5 3)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
+ exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-
-exit ${result}
\ No newline at end of file
diff --git a/unit-tests/nil.sh b/unit-tests/nil.sh
index c15f0b1..fcbf530 100755
--- 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 | 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
index 117c633..68f0447 100755
--- 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 | tail -1`
+actual=`echo "((nlambda (x) x) a)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
diff --git a/unit-tests/path-notation.sh b/unit-tests/path-notation.sh
index 3ba2e99..a6cb669 100755
--- a/unit-tests/path-notation.sh
+++ b/unit-tests/path-notation.sh
@@ -1,34 +1,31 @@
#!/bin/bash
-result=0
-
#####################################################################
# Create a path from root using compact path notation
-echo -n "$0: Create a path from root using compact path notation... "
-expected='(-> (oblist) :users :simon :functions (quote assoc))'
-actual=`echo "'/:users:simon:functions/assoc" | target/psse 2>&1 | tail -1`
+expected='(-> oblist :users :simon :functions (quote assoc))'
+actual=`echo "'/:users:simon:functions/assoc" | target/psse | tail -1`
+echo -n "Path from root (oblist) using compact notation: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
#####################################################################
# Create a path from the current session using compact path notation
-echo -n "$0: Create a path from the current session using compact path notation... "
expected='(-> session :input-stream)'
-actual=`echo "'$:input-stream" | target/psse 2>/dev/null | tail -1`
+actual=`echo "'$:input-stream" | target/psse | tail -1`
+echo -n "Path from current session using compact notation: "
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-exit ${result}
diff --git a/unit-tests/progn.sh b/unit-tests/progn.sh
index ea6cf7b..352c87a 100755
--- a/unit-tests/progn.sh
+++ b/unit-tests/progn.sh
@@ -1,29 +1,24 @@
#!/bin/bash
-result=0
-
-echo -n "$0: progn with one form... "
expected='5'
-actual=`echo "(progn (add 2 3))" | target/psse 2>/dev/null | tail -1`
+actual=`echo "(progn (add 2 3))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-echo -n "$0: progn with two forms... "
expected='"foo"'
-actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse 2>/dev/null | tail -1`
+actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
+ exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-
-exit ${result}
diff --git a/unit-tests/quote.sh b/unit-tests/quote.sh
index d98e215..78d4ce5 100755
--- a/unit-tests/quote.sh
+++ b/unit-tests/quote.sh
@@ -1,7 +1,7 @@
#!/bin/bash
expected='Fred'
-actual=`echo "'Fred" | target/psse 2>&1 | 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
index ade7b2a..f69cd75 100755
--- 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>&1 | 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
index 5e5bc7e..ba93c5d 100755
--- 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>&1 | 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
index e3aa586..6b5be2d 100755
--- a/unit-tests/recursion.sh
+++ b/unit-tests/recursion.sh
@@ -5,8 +5,8 @@ output=`target/psse 2>/dev/null <&1 | tail -1`
+actual=`echo '(reverse "The quick brown fox jumped over the lazy dog")' | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-echo -n "$0: reverse a list... "
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 2>&1 | tail -1`
+actual=`echo "(reverse '(2 4 8 16 32 64 128 256 512 1024))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-echo -n "$0: reverse a symbol... "
expected='esrever'
-actual=`echo "(reverse 'reverse)" | target/psse 2>&1 | tail -1`
+actual=`echo "(reverse 'reverse)" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
@@ -36,8 +31,6 @@ then
exit 0
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-exit ${result}
-
diff --git a/unit-tests/simple-list.sh b/unit-tests/simple-list.sh
index 6fb7e5d..daf3db2 100755
--- 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>&1 | 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
index 1b0b888..0a9bc7c 100755
--- a/unit-tests/slurp.sh
+++ b/unit-tests/slurp.sh
@@ -1,9 +1,9 @@
#!/bin/bash
-tmp=tmp/hi.$$
+tmp=hi.$$
echo "Hello, there." > ${tmp}
expected='"Hello, there.'
-actual=`echo "(slurp (open \"${tmp}\"))" | target/psse 2>&1 | tail -2 | head -1`
+actual=`echo "(slurp (open \"${tmp}\"))" | target/psse | tail -2 | head -1`
if [ "${expected}" = "${actual}" ]
then
@@ -11,6 +11,6 @@ then
rm ${tmp}
exit 0
else
- echo "$0 => Fail: expected '$expected', got '$actual'"
+ echo "Fail: expected '$expected', got '$actual'"
exit 1
fi
diff --git a/unit-tests/string-allocation.sh b/unit-tests/string-allocation.sh
index 1790788..6f55143 100755
--- a/unit-tests/string-allocation.sh
+++ b/unit-tests/string-allocation.sh
@@ -10,6 +10,6 @@ then
echo "OK"
exit 0
else
- echo "$0 => Fail: expected '${expected}', got '${actual}'"
+ echo "Fail: expected '${expected}', got '${actual}'"
exit 1
fi
diff --git a/unit-tests/string-cons.sh b/unit-tests/string-cons.sh
index 918dbc6..0ea0a71 100755
--- a/unit-tests/string-cons.sh
+++ b/unit-tests/string-cons.sh
@@ -1,30 +1,25 @@
#!/bin/bash
-result=0
-
-echo -n "$0: We should be able to cons a single character string onto the front of a string... "
+# 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 2>/dev/null | tail -1`
+actual=`echo '(cons "T" "est")' | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-echo -n "$0: But if the first argument has more than one character, we should get a dotted pair... "
+# 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 2>&1 | tail -1`
+actual=`echo '(cons "Test" "pass")' | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
+ exit 1
fi
-
-exit ${result}
-
diff --git a/unit-tests/string-with-spaces.sh b/unit-tests/string-with-spaces.sh
index 6a424fb..0f0f6d0 100755
--- 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>&1 | tail -1`
+actual=`echo ${expected} | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
diff --git a/unit-tests/subtract.sh b/unit-tests/subtract.sh
deleted file mode 100644
index 2c2e601..0000000
--- a/unit-tests/subtract.sh
+++ /dev/null
@@ -1,190 +0,0 @@
-#!/bin/bash
-
-# Tests for smallnum subtraction
-
-result=0
-
-
-echo -n "$0: (- 5 4)... "
-
-expected="1"
-actual=`echo "(- 5 4)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: (- 5.0 4)... "
-
-expected="1"
-actual=`echo "(- 5.0 4)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: (- 5 4.0)... "
-
-expected="1"
-actual=`echo "(- 5 4.0)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: (- 5.01 4.0)... "
-
-expected="1.0100000000000000002082"
-actual=`echo "(- 5.01 4.0)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: (- 5 4/5)... "
-
-expected="24/5"
-actual=`echo "(- 5 4/5)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: max smallint (- 1152921504606846975 1)... "
-
-expected="1,152,921,504,606,846,974"
-actual=`echo "(- 1152921504606846975 1)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: max smallint (- 1152921504606846975 1152921504606846974)... "
-
-expected="1"
-actual=`echo "(- 1152921504606846975 1152921504606846974)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: (- 4 5)... "
-
-expected="-1"
-actual=`echo "(- 4 5)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: (- 4 5.0)... "
-
-expected="-1"
-actual=`echo "(- 4 5.0)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: (- 4.0 5)... "
-
-expected="-1"
-actual=`echo "(- 4.0 5)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: (- 4.0 5.01)... "
-
-expected="-1.0100000000000000002082"
-actual=`echo "(- 4.0 5.01)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: (- 4/5 5)... "
-
-expected="-3/5"
-actual=`echo "(- 4/5 5)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: max smallint (- 1 1152921504606846975)... "
-
-expected="-1,152,921,504,606,846,974"
-actual=`echo "(- 1 1152921504606846975)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-echo -n "$0: max smallint (- 1152921504606846974 1152921504606846975)... "
-
-expected="-1"
-actual=`echo "(- 1152921504606846974 1152921504606846975)" | target/psse 2>/dev/null | tail -1`
-
-if [ "${expected}" = "${actual}" ]
-then
- echo "OK"
-else
- echo "Fail: expected '${expected}', got '${actual}'"
- result=`echo "${result} + 1" | bc`
-fi
-
-exit ${result}
diff --git a/unit-tests/try.sh b/unit-tests/try.sh
index b87ccee..a6d529c 100755
--- a/unit-tests/try.sh
+++ b/unit-tests/try.sh
@@ -1,54 +1,45 @@
#!/bin/bash
-result=0
-
-echo -n "$0: if the body of a try errors, the last form in the catch block is returned... "
expected=':foo'
-actual=`echo "(try ((+ 2 (/ 1 'a))) (:foo))" | target/psse 2>&1 | tail -1`
+actual=`echo "(try ((+ 2 (/ 1 'a))) (:foo))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-echo -n "$0: if the body of a try errors, the last form in the catch block is evaluated... "
-
expected='4'
-actual=`echo "(try ((+ 2 (/ 1 'a))) ((+ 2 2)))" | target/psse 2>&1 | tail -1`
+actual=`echo "(try ((+ 2 (/ 1 'a))) ((+ 2 2)))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-echo -n "$0: body and catch block can optionally be marked with keywords... "
expected='8'
-actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch (* 2 2 2)))" | target/psse 2>&1 | tail -1`
+actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch (* 2 2 2)))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-echo -n "$0: the exception is bound to the symbol \`*exception*\` in the catch environment... "
-expected='Exception: ((:location . /) (:payload . "Cannot divide: not a number"))'
-actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch *exception*))" | target/psse 2>&1 | grep Exception`
+expected=''
+actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch *exception*))" | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
echo "OK"
else
echo "Fail: expected '${expected}', got '${actual}'"
- return=`echo "${return} + 1" | bc`
+ exit 1
fi
-
-exit ${result}
diff --git a/unit-tests/varargs.sh b/unit-tests/varargs.sh
index 45ff627..27bac3e 100755
--- a/unit-tests/varargs.sh
+++ b/unit-tests/varargs.sh
@@ -1,7 +1,7 @@
#!/bin/bash
expected='(1 2 3 4 5 6 7 8 9 10)'
-actual=`echo "(set! list (lambda l l))(list 1 2 3 4 5 6 7 8 9 10)" | target/psse 2>&1 | tail -1`
+actual=`echo "(set! list (lambda l l))(list 1 2 3 4 5 6 7 8 9 10)" |target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then
diff --git a/unit-tests/wide-character.sh b/unit-tests/wide-character.sh
index 57dced6..d56544e 100755
--- a/unit-tests/wide-character.sh
+++ b/unit-tests/wide-character.sh
@@ -1,7 +1,7 @@
#!/bin/bash
expected='"λάμ(β)δα"'
-actual=`echo $expected | target/psse 2>&1 | tail -1`
+actual=`echo $expected | target/psse | tail -1`
if [ "${expected}" = "${actual}" ]
then