diff --git a/.gitignore b/.gitignore index b07b2a6..1968658 100644 --- a/.gitignore +++ b/.gitignore @@ -38,11 +38,3 @@ utils_src/readprintwc/out src/io/fopen hi\.* - -.vscode/ - -core - -.kdev4/ - -post-scarcity.kdev4 diff --git a/Makefile b/Makefile index 7e5efb4..c4c4ef3 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ SRC_DIRS ?= ./src SRCS := $(shell find $(SRC_DIRS) -name *.cpp -or -name *.c -or -name *.s) HDRS := $(shell find $(SRC_DIRS) -name *.h) -OBJS := $(addsuffix .o,$(basename $(SRCS))) +OBJS := $(addsuffix .o,$(basename $(SRCS))) DEPS := $(OBJS:.o=.d) TESTS := $(shell find unit-tests -name *.sh) @@ -17,12 +17,11 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG LDFLAGS := -lm -lcurl -DEBUGFLAGS := -g3 all: $(TARGET) $(TARGET): $(OBJS) Makefile - $(CC) $(DEBUGFLAGS) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) + $(CC) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) doc: $(SRCS) Makefile Doxyfile doxygen @@ -39,7 +38,7 @@ test: $(OBJS) $(TESTS) Makefile .PHONY: clean clean: - $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~ core + $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~ repl: $(TARGET) -p 2> psse.log diff --git a/README.md b/README.md index 8ea4dc4..9c08aab 100644 --- a/README.md +++ b/README.md @@ -1,33 +1,11 @@ # Post Scarcity Software System, version 0 +Very Nearly a Big Lisp Environment + tl,dr: look at the [wiki](wiki). ## State of play -### Version 0.0.5 - -Has working Lisp interpreter, more or less complete, with functions and symbols as defined under [#bindings-currently-available](Bindings currently available) below. Features include hash maps. - -#### Known bugs - -At the time of writing, big number arithmetic is completely failing. It has worked in the past, but it doesn't now. - -There are ludicrous memory leaks. Essentially the garbage collection strategy isn't yet really working. However, if we are to implement the hypercube architecture in future, a mark and sweep garbage collector will not work, so it's important to get the reference counter working properly. - -#### Unknown bugs - -There are certainly MANY unknown bugs. Please report those you find. - -#### Not yet implemented - -1. There is as yet no **compiler**, and indeed it isn't yet certain what a compiler would even mean. Do all nodes in a machine necessarily share the same processor architecture? -2. There's the beginnings of a narrative about how **namespaces** are going to work, but as yet they aren't really implemented. -3. There is as yet no implementation of the concept of **users**. Access Control Lists exist but are not used. Related, there's no concept of a **session**. -4. There is as yet no **multiprocessor architecture**, not even a simulated one. As it is intended that threading will be implemented by handing off parts of a computation to peer processors, this means there no **threads** either. -5. There's no **user interface** beyond a REPL. There isn't even an **editor**, or **history**. -6. **Printing to strings** does not work. -7. The **exception system**, while it does exist, needs to be radically rethought. - ### Version 0.0.4 Has working rational number arithmetic, as well as integer and real number arithmetic. The stack is now in vector space, but vector space is not yet properly garbage collected. `defun` does not yet work, so although Lisp functions can be defined the syntax is pretty clunky. So you *can* start to do things with this, but you should probably wait for at least a 0.1.0 release! @@ -44,349 +22,6 @@ What I'm trying to do now is write a detailed low level specification of the und Although I describe it as a 'Lisp environment', for reasons explained in Post Scarcity Software that doesn't mean you will program it in Lisp. It means that the underlying representation of things in the system is Lispy, not Unixy. -## Bindings currently available - -The following symbols are bound in the bootstrap layer. It is anticipated that - -1. Most of the functions will be overridden by versions of the same function written in Lisp; but -2. these implementations will remain available in the namespace `/:bootstrap`. - -### Values - -Note that symbols delimited by asterisks, as in `*in*`, invite rebinding; it is expected, for example, that users will want to rebind input and output streams in their current environment. Rebinding some other symbols, for example `nil`, is unwise. - -#### nil - -The canonical empty list. - -#### t - -The canonical true value. - -#### \*in\* - -The input stream. - -#### \*out\* - -The output stream. - -#### \*log\* - -The logging stream (equivalent to `stderr`). - -#### \*sink\* - -The sink stream (equivalent to `/dev/null`). - -#### \*prompt\* - -The REPL prompt. - -### Functions - -#### (absolute *n*) - -Return the absolute value of a number. - -#### (add *n1* *n2* ...), (+ *n1* *n2* ...) - -Return the result of adding together all the (assumed numeric) arguments supplied. - -#### (append *s1* *s2* ...) - -Return a new sequence comprising all the elements of *s1* followed by all the elements of *s2* and so on for an indefinite number of arguments. All arguments must be sequences of the same type. - -#### (apply *f* *s*) - -Apply the function *f* to the arguments that form the sequence *s*, and return the result. - -#### (assoc *key* *store*) - -Return the value associated with *key* in *store*. *key* may be an object of any type, but keywords, symbols and strings are handled most efficiently. *store* may be an [*association list*](#Association_list), or may be a hashmap. - -#### (car *s*) - -Return the first element of the sequence *s*. - -#### (cdr *s*) - -Return a sequence of all the elements of the sequence *s* except the first. - -#### (close *stream*) - -Closes the indicates stream. Returns `nil`. - -#### (cons *a* *b*) - -Returns a new pair comprising *a* and *b*. If *b* is a list, this has the effect of creating a new list with the element *a* prepended to all the elements of *b*. If *b* is `nil`, this has the effect creating a new list with *a* as the sole element. Otherwise, it just creates a pair. - -#### (divide *n1* *n2*), (/ *n1* *n2*) - -Divides the number *n1* by the number *n2*. If *n1* and *n2* are both integers, it's likely that the result will be a rational number. - -#### (eq *o1* *o2*) - -Returns true (`t`) if *o1* and *o2* are identically the same object, else `nil`. - -#### (equal *o1* *o2*), (= *o1* *o2*) - -Returns true (`t`) if *o1* and *o2* are structurally identical to one another, else `nil`. - -#### (exception *message*) - -Throws (returns) an exception, with the specified *message*. Note that this doesn't really work at all well, and that it is extremely likely this signature will change. - -#### (get-hash *key* *hashmap*) - -Like 'assoc', but the store must be a hashmap. Deprecated. - -#### (hashmap *n* *f* *store*) - -Create a hashmap with *n* buckets, using *f* as its hashing function, and initialised with the key/value pairs from *store*. All arguments are optional; if none are passed, will create an empty hashmap with 32 keys and the default hashing function. - -#### (inspect *o*) - -Prints detailed structure of the object *o*. Primarily for debugging. - -#### (keys *store*) - -Returns a list of the keys in *store*, which may be either an [*association list*](#Association_list), or a hashmap. - -#### (let *bindings* *form*...) - -Evaluates each of the *forms* in an environment to which ally of these *bindings* have been added. *bindings* must be an [*association list*](#Association_list), and, additionally, all keys in *bindings* must be symbols. Values in the association list will be evaluated before being bound, and this is done sequentially, as in the behaviour of Common Lisp `let*` rather than of Common Lisp `let`. - -#### (list *o*...) - -Returns a list of the values of all of its arguments in sequence. - -#### (mapcar *f* *s*) - -Applies the function *f* to each element of the sequence *s*, and returns a new sequence of the results. - -#### (meta *o*), (metadata *o*) - -Returns metadata on *o*. - -#### (multiply *n1* *n2* ...), (\* *n1* *n2* ...) - -Returns the product of multiplying together all of its numeric arguments. - -#### (negative? n1) - -Returns `t` if its argument is a negative number, else `nil`. - -#### (oblist) - -Returns a sequence of all the names bound in the root of the naming system. - -#### (open *url* *read?*) - -Opens a stream to the specified *url*. If a second argument is present and is non-`nil`, the stream is opened for reading; otherwise, it's opened for writing. - -#### (print *o* [*stream*]) - -Prints the print-name of object *o* to the output stream which is the value of *stream*, or to the value of \*out\* in the current environment if no *stream* is provided. - -#### (put! *map* *key* *value*) - -Puts *value* as the value of *key* in hashmap *map*, destructively modifying it, and returns the map. Note that in future this will work only if the current user has write access to the specified map. - -#### (put-all! *map* *assoc*) - -Puts each (+key* . *value*) pair from the association list *assoc* into this *map*, destructively modifying it, and returns the map. Note that in future this will work only if the current user has write access to the specified map. - -#### (read [*stream*]) - -Reads a single Lisp form from the input stream which is the value of *stream*, or from the value of \*in\* in the current environment if no *stream* is provided. - -#### (read-char [*stream*]) - -Return the next character from the stream indicated by *stream*, or from the value of \*in\* in the current environment if no *stream* is provided; further arguments are ignored. - -#### (repl [*prompt* *input* *output*)) - -Initiate a new Read/Eval/Print loop with this *prompt*, reading from this *input* stream and writing to this *output* stream. All arguments are optional and default sensibly if omitted. TODO: doesn't actually work yet. - -#### (reverse *seq*) - -Return a new sequence of the same type as *seq*, containing the same elements but in the reverse order. - -#### (slurp *in*) - -Reads all available characters on input stream *in* into a string, and returns the string. - -#### (source *fn*) - -Should return the source code of the function or special form *fn*, but as we don't yet -have a compiler, doesn't. - -#### (subtract *n1* *n2*), (- *n1* *n2*) - -Subtracts the numeric value *n2* from the numeric value *n1*, and returns the difference. - -#### (throw *message*) - -Throws an exception, with the payload *message*. While *message* is at present most usefully a string, it doesn't have to be. Returns the exception, but as exceptions are handled specially by `eval`, it is returned to the catch block of the nearest `try` expression on the stack. - -#### (time [*milliseconds-since-epoch*]) - -Returns a time object whose value is the specified number of *milliseconds-since-epoch*, where the Post Scarcity Software Environment epoch is 14 billion years prior to the UN*X epoch. If *milliseconds-since-epoch* is not specified, returns a time object representing the UTC time when the function was executed. - -#### (type *o*) - -Returns a string representing the type -- actually the tag value -- of the object *o*. - -### Special forms - -#### (cond (test value) ...) - -Evaluates a series of *(test value)* clauses in turn until a test returns non-nil, when the corresponding value is returned and further tests are not evaluated. This is the same syntax as Common Lisp's `cond` implementation, and different from Clojure's. - -It's conventional in Lisp to have a final clause in a `cond` block with the test `t`; however, since we have keywords which are always truthy, it would be equally valid to use `:else` or `:default` as final fallback tests. - -#### (lambda (arg ...) form ...), (λ (arg ...) form ...) - -Returns an anonymous fuction which evaluates each of the *form*s sequentially in an environment in which the specified *arg*s are bound, and returns the value of the last such form. - -#### (let ((*var* . *val*) ...) form ...) - -Evaluates each of these *form*s sequentially in an environment in which each *var* is bound to the respective *val* in the bindings specified, and returns the value of the last form. - -#### (nlambda (arg ...) form ...), (nλ (arg ...) form ...) - -Returns an anonymous special form which evaluates each of the *form*s sequentially in an environment in which the specified *arg*s are bound, and returns the value of the last such form. - -#### (progn *f* ...) - -Evaluates each of the forms which are its arguments in turn and returns the value of the last. - -#### (quote *o*), '*o* - -Returns *o*, unevaluated. - -#### (set! *name* *value* [*namespace*]) - -Sets (destructively modifies) the value of *name* this *value* in the root namespace. The *namespace* argument is currently ignored but in future is anticipated to be a path specification of a namespace to be modified. - -#### (try (*form* ...) (*handler* ...)) - -Attempt to evaluate, sequentially, each of the *form*s in the first sequence, and return the value of the last of them; however, if any of them cause an exception to be thrown, then evaluate sequentially each of the *handler*s in the second sequence. - -It is recommended that you structure this as follows: - -`lisp - (try - (:body - (print "hello") - (/ 1 'a) - (print "goodbye")) - (:catch - (print "Well, that failed.") - 5)) -` - -Here, `:body` and `:catch` are syntactic sugar which will not affect the final value. - -### Type values - -The following types are known. Further types can be defined, and ultimately it should be possible to define further types in Lisp, but these are what you have to be going on with. Note that where this documentation differs from `memory/consspaceobject.h`, this documentation is *wrong*. - -#### CONS - -An ordinary cons cell: that is to say, a pair. - -#### EXEP - -An exception - -#### FREE - -An unallocated memory cell. User programs should never see this. - -#### FUNC - -A primitive or compiled Lisp function \-- one whose arguments are pre-evaluated. - -#### HASH - -A hash map (in vector space) - -#### INTR - -An arbitrarily large integer number. - -#### KEYW - -A keyword - an interned, self-evaluating string. - -#### LMBA - -A lambda cell. Lambdas are the interpretable (source) versions of functions. - -#### LOOP - -Internal to the workings of the ••loop** function. User functions should never see this. - -#### NIL - -The special cons cell at address {0,0} whose **car** and **cdr** both point to itself. The canonical empty set. Generally, treated as being indicative of falsity. - -#### NLMD - -An nlambda cell. NLambdas are the interpretable (source) versions of special forms. - -#### RTIO - -A rational number, stored as pointers two integers representing dividend and divisor respectively. - -#### READ - -An open read stream. - -#### REAL - -A real number, represented internally as an IEEE 754-2008 `binary64`. - -#### SPFM - -A compiled or primitive special form - one whose arguments are not pre-evaluated but passed as provided. - -#### STAK - -A stack frame. In vector space. - -#### STRG - -A string of [UTF-32](https://en.wikipedia.org/wiki/UTF-32) characters, stored as a linked list. Self evaluating. - -#### SYMB - -A symbol is just like a string except not self-evaluating. Later, there may be some restrictions on what characters are legal in a symbol, but at present there are not. - -#### TIME - -A time stamp. The epoch for the Post Scarcity Software Environment is 14 billion years before the UN*X epoch, and is chosen as being a reasonable estimate for the birth of the universe, and thus of the start of time. - -#### TRUE - -The special cell at address {0,1} which is canonically different from NIL. - -#### VECP - -A pointer to an object in vector space. User functions shouldn't see this, they should see the type of the vector-space object indicated. - -#### VECT - -A vector of objects. In vector space. - -#### WRIT - -An open write stream. - - - ## License Copyright © 2017 [Simon Brooke](mailto:simon@journeyman.cc) diff --git a/docs/How-do-we-notate-paths.md b/docs/How-do-we-notate-paths.md deleted file mode 100644 index 7cdbcb0..0000000 --- a/docs/How-do-we-notate-paths.md +++ /dev/null @@ -1,89 +0,0 @@ -# How do we notate paths? - -In order to make the namespaces thing work, we need a convenient way to notate paths from the current namespace to a target, or from the root to a target. This is similar to relative and absolute paths in UNIX, except that in PSSE there is no concept of a single or privileged ancestor namespace to the current namespace, so you have no equivalent of `../`. - -In this discussion, a **namespace** is just a named, mutable hashmap (but not necessarily mutable by all users; indeed namespaces will almost always be mutable only by selected users. I cannot presently see a justified use for a publicly writable namespace). '**Named**', of a hashmap, merely means there is some path from the privileged root namespace which is the value of `oblist` which leads to that hashmap. A **path** is in principle just a sequence of keys, such that the value of each successive key is bound to a namespace in the namespace bound by its predecessor. The evaluable implementation of paths will be discussed later. - -I think also that there must be a privileged **session** namespace, containing information about the current session, which the user can read but not write. - -## Security considerations - -What's important is that a user cannot rebind privileged names in their own environment. Thus to ensure privileged names, such names must be paths either from the `oblist`or from the current session. So we need magic, privileged notations for these things built into the reader, which cannot be overridden. - -This kind of takes away from my general feeling that users should be able to override *anything*. but hey, that's engineering for you. - -Users should be able to override reader macros generally; a programmable reader is in the medium term something which should be implemented. But the privileged syntax for paths should not be overridable. - -## Current state of the reader - -At present, you can rebind the value of the symbol `oblist` in the runtime environment. In principle, you should be able to rebind any symbol. Paths and symbols are not the same. - -At present, the colon character is a separator character. So if you type - -> (list :foo:bar:ban) - -the reader will return - -> (list :foo :bar :ban) - -That's significant, and helpful. - -## Constructing path notation - -The Clojure threading macro, `->`, is a useful example of how we can implement this. Essentially it takes a expression as its first argument, passes the value of that expression to the function which is its second argument, the value of that as argument to the function which is its next, and so on. Given that, in Clojure, an expression which has a keyword in the function position and a hashmap in the argument position will return the value of that keyword in that hashmap, this means that, given the hashmap - -> (def x {:foo {:bar {:ban "Howzat!!"}}}) - -the expression - -> (-> x :foo :bar :ban) - -will return - -> "Howzat!!" - -So, in general, if we implement the 'keyword in the function position' `eval` hack and the threading macro, then something like - -> (-> oblist :users :simon :functions 'foo) - -should return the value of the symbol `foo` in the `:functions` of the user called `:simon`. - -That's stage one of our goal. - -Stage two of our goal is that a stream of non-separator characters separated by colons should be interpreted as a list of keywords. Thus typing - -> :foo:bar:ban - -should result in not just `:foo`being read, but the list `(:foo :bar :ban)`(? not sure about this) - -Stage 3 is to allow a symbol to be appended to a sequence of keywords written by using `/`as a separator, so - -> :foo:bar/ban - -would be read as `(:foo :bar 'ban)` - -Finally, we need privileged notation for root (oblist) and for session. There are very few non-alpha-numeric characters which are available on a standard keyboard and which are not already used as significant lexical characters in Lisp readers. PSSE is not limited, of course, to the characters which are part of the ASCII character set, but it is helpful to use symbols which are reasonably convenient to type, possibly with special keyboard bindings. - -So I'm going to propose that the reader should interpret - -> /:users:simon:functions/assoc - -as - -> (-> oblist :users :simon :functions 'assoc) - -where `oblist` is the actual privileged global object list, not just the current binding of `oblist` in the environment. Thus, this expression would return my personal version of the function `assoc`, whatever the symbol `assoc` was bound to in the runtime environment. - -The use of the leading slash here follows UNIX convention. - -I'm going to suggest that the session is referenced by the character §, otherwise known as the 'silcrow'. This is not available on most keyboard mappings, so a custom mapping might be needed, or we might have to fall back on `$`. - -Thus the reader should interpret - -> §:user - -as - -> (-> session :user) - -where `session`is again a system privileged value, not the binding of `session` in the current environment. \ No newline at end of file diff --git a/docs/Hybrid-assoc-lists.md b/docs/Hybrid-assoc-lists.md deleted file mode 100644 index 5bb6ca8..0000000 --- a/docs/Hybrid-assoc-lists.md +++ /dev/null @@ -1,40 +0,0 @@ -# Hybrid assoc lists - -In it's current very prototype stage, PSSE has to forms of name/value store. One is the assoc list, the other is the hashmap. - -An assoc (association) list is a list of the form: - - ((name1 . value1)(name2 . value2)(name3 . value3)...) - -Hashmaps have many very clear advantages, but assoc lists have one which is very important in the evaluation environment, and that is precisely its sequentiality. Thus, if the same name is bound twice on an assoc list, the value nearest the head is the one which will be recovered: - - (assoc :bar '((:foo . 1) (:bar . "Hello there!")(:ban . 3)(:bar . 2))) - => "Hello there!" - -Why does this matter? Well, for precisely the same reason it matters when a UNIX system searches for an executable. - -Suppose Clare is a user who trusts both Alice and Bob, but she trusts Alice more than Bob. Suppose both Alice and Bob have written implementations of a function called `froboz`. Suppose Clare invokes - - (froboz 3) - -Which implementation of `froboz` should be evaluated? An assoc list makes that simple. If Clare binds Alice's implementation into her environment later than Bob's, Alice's will be the one found. - -But an assoc list is also fearsomely inefficient, especially if we are in a system with many thousands of names, each of which may be bound multiple times in typical runtime environment. - -How to resolve this? How to get some of the benefits of sequential access of assoc lists, with some of the efficiency benefits of hashmaps? What I'm going to propose is a **hybrid assoc list**, that is to say, a list whose members are either - -1. (key . value) pairs, or else -2. hashmaps. - -So suppose we have a list, `l`, thus: - - ((:foo . 1) (:bar . 2) {:foo "not this" :ban 3} (:ban . "not this either") (:froboz . 4)) - -Then: - - (assoc :foo l) => 1 - (assoc :bar l) => 2 - (assoc :ban l) => 3 - (assoc :froboz l) => 4 - -This will make the implementation of namespaces and search paths vastly easier. \ No newline at end of file diff --git a/lisp/defun.lisp b/lisp/defun.lisp index a6d80f5..cec893b 100644 --- a/lisp/defun.lisp +++ b/lisp/defun.lisp @@ -9,11 +9,6 @@ (set (car form) (apply 'lambda (cdr form)))) (t nil)))) -(set! defun! - (nlambda - form - (eval (list 'set! (car form) (cons 'lambda (cdr form)))))) - (defun! square (x) (* x x)) (set! defsp! diff --git a/src/arith/integer.c b/src/arith/integer.c index eef171b..1b2667c 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -18,12 +18,12 @@ #include #include -#include "memory/conspage.h" -#include "memory/consspaceobject.h" +#include "conspage.h" +#include "consspaceobject.h" #include "debug.h" -#include "ops/equal.h" -#include "ops/lispops.h" -#include "arith/peano.h" +#include "equal.h" +#include "lispops.h" +#include "peano.h" /** * hexadecimal digits for printing numbers. @@ -46,10 +46,11 @@ struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { debug_print( L"Entering make_integer\n", DEBUG_ALLOC ); if ( integerp( more ) || nilp( more ) ) { - result = allocate_cell( INTEGERTV ); + result = allocate_cell( INTEGERTAG ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.integer.value = value; cell->payload.integer.more = more; + } debug_print( L"make_integer: returning\n", DEBUG_ALLOC ); @@ -76,7 +77,7 @@ __int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { __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 ", + 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 ); @@ -218,19 +219,18 @@ struct cons_pointer base_partial( int depth ) { /** * destructively modify this `partial` by appending this `digit`. */ -struct cons_pointer append_digit( struct cons_pointer partial, - struct cons_pointer digit ) { +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 ) ) { + if (nilp( partial)) { result = digit; } else { - while ( !nilp( pointer2cell( c ).payload.integer.more ) ) { - c = pointer2cell( c ).payload.integer.more; + 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; } @@ -249,8 +249,8 @@ struct cons_pointer append_digit( struct cons_pointer partial, * @param b an integer. */ struct cons_pointer multiply_integers( struct cons_pointer a, - struct cons_pointer b ) { - struct cons_pointer result = make_integer( 0, NIL ); + struct cons_pointer b ) { + struct cons_pointer result = make_integer( 0, NIL); bool neg = is_negative( a ) != is_negative( b ); bool is_first_b = true; int i = 0; @@ -265,7 +265,7 @@ struct cons_pointer multiply_integers( struct cons_pointer a, /* for each digit in a, starting with the least significant (ai) */ for ( struct cons_pointer ai = a; !nilp( ai ); - ai = pointer2cell( ai ).payload.integer.more ) { + ai = pointer2cell(ai).payload.integer.more) { /* set carry to 0 */ __int128_t carry = 0; @@ -275,41 +275,41 @@ struct cons_pointer multiply_integers( struct cons_pointer a, /* for each digit in b, starting with the least significant (bj) */ for ( struct cons_pointer bj = b; !nilp( bj ); - bj = pointer2cell( bj ).payload.integer.more ) { + bj = pointer2cell(bj).payload.integer.more) { debug_printf( DEBUG_ARITH, - L"multiply_integers: a[i] = %Ld, b[j] = %Ld, i = %d\n", - pointer2cell( ai ).payload.integer.value, - pointer2cell( bj ).payload.integer.value, i ); + L"multiply_integers: a[i] = %Ld, b[j] = %Ld, i = %d\n", + pointer2cell(ai).payload.integer.value, + pointer2cell(bj).payload.integer.value, i); /* multiply ai with bj and add the carry, resulting in a * value xj which may exceed one digit */ - __int128_t xj = pointer2cell( ai ).payload.integer.value * - pointer2cell( bj ).payload.integer.value; + __int128_t xj = pointer2cell(ai).payload.integer.value * + pointer2cell(bj).payload.integer.value; xj += carry; /* if xj exceeds one digit, break it into the digit dj and * the carry */ carry = xj >> 60; - struct cons_pointer dj = make_integer( xj & MAX_INTEGER, NIL ); + struct cons_pointer dj = make_integer( xj & MAX_INTEGER, NIL); /* destructively modify ri by appending dj */ - ri = append_digit( ri, dj ); - } /* end for bj */ + ri = append_digit( ri, dj); + } /* end for bj */ /* if carry is not equal to zero, append it as a final digit * to ri */ - if ( carry != 0 ) { - ri = append_digit( ri, make_integer( carry, NIL ) ); + if (carry != 0) { + ri = append_digit( ri, make_integer( carry, NIL)); } /* add ri to result */ - result = add_integers( result, ri ); + result = add_integers( result, ri); debug_print( L"multiply_integers: result is ", DEBUG_ARITH ); debug_print_object( result, DEBUG_ARITH ); debug_println( DEBUG_ARITH ); - } /* end for ai */ + } /* end for ai */ } debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); @@ -343,16 +343,13 @@ struct cons_pointer integer_to_string_add_digit( int digit, int digits, * to be looking to the next. H'mmmm. */ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, - int base ) { + int base ) { struct cons_pointer result = NIL; if ( integerp( int_pointer ) ) { - struct cons_pointer next = - pointer2cell( int_pointer ).payload.integer.more; - __int128_t accumulator = - llabs( pointer2cell( int_pointer ).payload.integer.value ); - bool is_negative = - pointer2cell( int_pointer ).payload.integer.value < 0; + struct cons_pointer next = pointer2cell( int_pointer ).payload.integer.more; + __int128_t accumulator = llabs( pointer2cell( int_pointer ).payload.integer.value ); + bool is_negative = pointer2cell( int_pointer ).payload.integer.value < 0; int digits = 0; if ( accumulator == 0 && nilp( next ) ) { @@ -360,14 +357,13 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, } else { while ( accumulator > 0 || !nilp( next ) ) { if ( accumulator < MAX_INTEGER && !nilp( next ) ) { - accumulator += - ( pointer2cell( next ).payload.integer.value << 60 ); - next = pointer2cell( next ).payload.integer.more; + accumulator += (pointer2cell(next).payload.integer.value << 60); + next = pointer2cell(next).payload.integer.more; } int offset = ( int ) ( accumulator % base ); debug_printf( DEBUG_IO, - L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", - offset, hex_digits[offset] ); + L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", + offset, hex_digits[offset] ); debug_print_128bit( accumulator, DEBUG_IO ); debug_print( L"; result is: ", DEBUG_IO ); debug_print_object( result, DEBUG_IO ); @@ -379,7 +375,7 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, } if ( stringp( result ) - && pointer2cell( result ).payload.string.character == L',' ) { + && pointer2cell( result ).payload.string.character == L',' ) { /* if the number of digits in the string is divisible by 3, there will be * an unwanted comma on the front. */ result = pointer2cell( result ).payload.string.cdr; @@ -394,38 +390,3 @@ struct cons_pointer integer_to_string( struct cons_pointer int_pointer, return result; } - -/** - * true if a and be are both integers whose value is the same value. - */ -bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ) { - bool result = false; - - if ( integerp( a ) && integerp( b ) ) { - struct cons_space_object *cell_a = &pointer2cell( a ); - struct cons_space_object *cell_b = &pointer2cell( b ); - - result = - cell_a->payload.integer.value == cell_b->payload.integer.value; - } - - 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 09a7a83..117a0bf 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -11,9 +11,6 @@ #ifndef __integer_h #define __integer_h -#include -#include - struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); struct cons_pointer add_integers( struct cons_pointer a, @@ -25,8 +22,4 @@ struct cons_pointer multiply_integers( struct cons_pointer a, struct cons_pointer integer_to_string( struct cons_pointer int_pointer, int base ); -bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ); - -bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ); - #endif diff --git a/src/arith/peano.c b/src/arith/peano.c index ae23a00..8e4cb43 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -14,19 +14,19 @@ #include #include -#include "memory/consspaceobject.h" -#include "memory/conspage.h" +#include "consspaceobject.h" +#include "conspage.h" #include "debug.h" -#include "ops/equal.h" -#include "arith/integer.h" -#include "ops/intern.h" -#include "ops/lispops.h" -#include "arith/peano.h" -#include "io/print.h" -#include "arith/ratio.h" -#include "io/read.h" -#include "arith/real.h" -#include "memory/stack.h" +#include "equal.h" +#include "integer.h" +#include "intern.h" +#include "lispops.h" +#include "peano.h" +#include "print.h" +#include "ratio.h" +#include "read.h" +#include "real.h" +#include "stack.h" long double to_long_double( struct cons_pointer arg ); int64_t to_long_int( struct cons_pointer arg ); @@ -86,7 +86,8 @@ bool is_negative( struct cons_pointer arg ) { return result; } -struct cons_pointer absolute( struct cons_pointer arg ) { +struct cons_pointer absolute( struct cons_pointer frame_pointer, + struct cons_pointer arg ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); @@ -98,7 +99,9 @@ struct cons_pointer absolute( struct cons_pointer arg ) { cell.payload.integer.more ); break; case RATIOTV: - result = make_ratio( absolute( cell.payload.ratio.dividend ), + result = make_ratio( frame_pointer, + absolute( frame_pointer, + cell.payload.ratio.dividend ), cell.payload.ratio.divisor ); break; case REALTV: @@ -207,7 +210,7 @@ int64_t to_long_int( struct cons_pointer arg ) { struct cons_pointer lisp_absolute( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - return absolute( frame->arg[0] ); + return absolute( frame_pointer, frame->arg[0] ); } /** @@ -247,7 +250,8 @@ struct cons_pointer add_2( struct stack_frame *frame, result = add_integers( arg1, arg2 ); break; case RATIOTV: - result = add_integer_ratio( arg1, arg2 ); + result = + add_integer_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = @@ -267,10 +271,11 @@ struct cons_pointer add_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = add_integer_ratio( arg2, arg1 ); + result = + add_integer_ratio( frame_pointer, arg2, arg1 ); break; case RATIOTV: - result = add_ratio_ratio( arg1, arg2 ); + result = add_ratio_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = @@ -378,7 +383,9 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = multiply_integers( arg1, arg2 ); break; case RATIOTV: - result = multiply_integer_ratio( arg1, arg2 ); + result = + multiply_integer_ratio( frame_pointer, arg1, + arg2 ); break; case REALTV: result = @@ -401,10 +408,13 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = multiply_integer_ratio( arg2, arg1 ); + result = + multiply_integer_ratio( frame_pointer, arg2, + arg1 ); break; case RATIOTV: - result = multiply_ratio_ratio( arg1, arg2 ); + result = + multiply_ratio_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = @@ -486,7 +496,8 @@ struct cons_pointer lisp_multiply( struct * return a cons_pointer indicating a number which is the * 0 - the number indicated by `arg`. */ -struct cons_pointer negative( struct cons_pointer arg ) { +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); @@ -503,7 +514,9 @@ struct cons_pointer negative( struct cons_pointer arg ) { result = TRUE; break; case RATIOTV: - result = make_ratio( negative( cell.payload.ratio.dividend ), + result = make_ratio( frame, + negative( frame, + cell.payload.ratio.dividend ), cell.payload.ratio.divisor ); break; case REALTV: @@ -557,18 +570,20 @@ struct cons_pointer subtract_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV:{ - struct cons_pointer i = negative( arg2 ); + struct cons_pointer i = + negative( frame_pointer, arg2 ); inc_ref( i ); result = add_integers( arg1, i ); dec_ref( i ); } break; case RATIOTV:{ - struct cons_pointer tmp = make_ratio( arg1, - make_integer( 1, - NIL ) ); + struct cons_pointer tmp = + make_ratio( frame_pointer, arg1, + make_integer( 1, NIL ) ); inc_ref( tmp ); - result = subtract_ratio_ratio( tmp, arg2 ); + result = + subtract_ratio_ratio( frame_pointer, tmp, arg2 ); dec_ref( tmp ); } break; @@ -590,16 +605,17 @@ struct cons_pointer subtract_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV:{ - struct cons_pointer tmp = make_ratio( arg2, - make_integer( 1, - NIL ) ); + struct cons_pointer tmp = + make_ratio( frame_pointer, arg2, + make_integer( 1, NIL ) ); inc_ref( tmp ); - result = subtract_ratio_ratio( arg1, tmp ); + result = + subtract_ratio_ratio( frame_pointer, arg1, tmp ); dec_ref( tmp ); } break; case RATIOTV: - result = subtract_ratio_ratio( arg1, arg2 ); + result = subtract_ratio_ratio( frame_pointer, arg1, arg2 ); break; case REALTV: result = @@ -671,11 +687,11 @@ struct cons_pointer lisp_divide( struct break; case INTEGERTV:{ struct cons_pointer unsimplified = - make_ratio( frame->arg[0], + make_ratio( frame_pointer, frame->arg[0], frame->arg[1] ); /* OK, if result may be unsimplified, we should not inc_ref it * - but if not, we should dec_ref it. */ - result = simplify_ratio( unsimplified ); + result = simplify_ratio( frame_pointer, unsimplified ); if ( !eq( unsimplified, result ) ) { dec_ref( unsimplified ); } @@ -684,9 +700,11 @@ struct cons_pointer lisp_divide( struct case RATIOTV:{ struct cons_pointer one = make_integer( 1, NIL ); struct cons_pointer ratio = - make_ratio( frame->arg[0], one ); + make_ratio( frame_pointer, frame->arg[0], one ); inc_ref( ratio ); - result = divide_ratio_ratio( ratio, frame->arg[1] ); + result = + divide_ratio_ratio( frame_pointer, ratio, + frame->arg[1] ); dec_ref( ratio ); } break; @@ -711,16 +729,19 @@ struct cons_pointer lisp_divide( struct struct cons_pointer one = make_integer( 1, NIL ); inc_ref( one ); struct cons_pointer ratio = - make_ratio( frame->arg[1], one ); + make_ratio( frame_pointer, frame->arg[1], one ); inc_ref( ratio ); - result = divide_ratio_ratio( frame->arg[0], ratio ); + result = + divide_ratio_ratio( frame_pointer, frame->arg[0], + ratio ); dec_ref( ratio ); dec_ref( one ); } break; case RATIOTV: result = - divide_ratio_ratio( frame->arg[0], frame->arg[1] ); + divide_ratio_ratio( frame_pointer, frame->arg[0], + frame->arg[1] ); break; case REALTV: result = diff --git a/src/arith/peano.h b/src/arith/peano.h index 3076391..7ad7662 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -19,16 +19,16 @@ bool zerop( struct cons_pointer arg ); -struct cons_pointer negative( struct cons_pointer arg ); +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ); bool is_negative( struct cons_pointer arg ); -struct cons_pointer absolute( struct cons_pointer arg ); +struct cons_pointer absolute( struct cons_pointer frame_pointer, + struct cons_pointer arg ); long double to_long_double( struct cons_pointer arg ); -int64_t to_long_int( struct cons_pointer arg ); - struct cons_pointer lisp_absolute( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); @@ -46,7 +46,8 @@ struct cons_pointer lisp_multiply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer negative( struct cons_pointer arg ); +struct cons_pointer negative( struct cons_pointer frame, + struct cons_pointer arg ); struct cons_pointer subtract_2( struct stack_frame *frame, struct cons_pointer frame_pointer, diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 5135d6b..65b09da 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -11,15 +11,15 @@ #include #include -#include "memory/conspage.h" -#include "memory/consspaceobject.h" +#include "conspage.h" +#include "consspaceobject.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" +#include "equal.h" +#include "integer.h" +#include "lispops.h" +#include "peano.h" +#include "print.h" +#include "ratio.h" /** @@ -43,46 +43,52 @@ int64_t least_common_multiple( int64_t m, int64_t n ) { return m / greatest_common_divisor( m, n ) * 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 ); +/** + * return a cons_pointer indicating a number which is of the + * same value as the ratio indicated by `arg`, but which may + * be in a simplified representation. + * @exception If `arg` isn't a ratio, will return an exception. + */ +struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg ) { + struct cons_pointer result = arg; - 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 ( ratiop( arg ) ) { + int64_t ddrv = + pointer2cell( pointer2cell( arg ).payload.ratio.dividend ). + payload.integer.value, drrv = + pointer2cell( pointer2cell( arg ).payload.ratio.divisor ). + payload.integer.value, gcd = greatest_common_divisor( ddrv, drrv ); - if ( gcd > 1 ) { - if ( drrv / gcd == 1 ) { - result = make_integer( ddrv / gcd, NIL ); - } else { - result = - make_ratio( make_integer( ddrv / gcd, NIL ), - make_integer( drrv / gcd, NIL ) ); - } + if ( gcd > 1 ) { + if ( drrv / gcd == 1 ) { + result = make_integer( ddrv / gcd, NIL ); + } else { + result = + make_ratio( frame_pointer, make_integer( ddrv / gcd, NIL ), + make_integer( drrv / gcd, NIL ) ); } } + } else { + result = + throw_exception( make_cons( c_string_to_lisp_string + ( L"Shouldn't happen: bad arg to simplify_ratio" ), + arg ), frame_pointer ); } return result; - } + /** * return a cons_pointer indicating a number which is the sum of * the ratios indicated by `arg1` and `arg2`. * @exception will return an exception if either `arg1` or `arg2` is not a * rational number. */ -struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, +struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer r, result; @@ -110,17 +116,18 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, m1, m2 ); if ( dr1v == dr2v ) { - r = make_ratio( make_integer( dd1v + dd2v, NIL ), + r = make_ratio( frame_pointer, + 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 ); + r1 = make_ratio( frame_pointer, dd1vm, dr1vm ), + r2 = make_ratio( frame_pointer, dd2vm, dr2vm ); - r = add_ratio_ratio( r1, r2 ); + r = add_ratio_ratio( frame_pointer, r1, r2 ); /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were * never incremented except when making r1 and r2, decrementing @@ -129,7 +136,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, dec_ref( r2 ); } - result = simplify_ratio( r ); + result = simplify_ratio( frame_pointer, r ); if ( !eq( r, result ) ) { dec_ref( r ); } @@ -139,7 +146,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, ( L"Shouldn't happen: bad arg to add_ratio_ratio" ), make_cons( arg1, make_cons( arg2, NIL ) ) ), - NIL ); + frame_pointer ); } debug_print( L" => ", DEBUG_ARITH ); @@ -156,16 +163,16 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, * `ratarg`. * @exception if either `intarg` or `ratarg` is not of the expected type. */ -struct cons_pointer add_integer_ratio( struct cons_pointer intarg, +struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, + struct cons_pointer intarg, struct cons_pointer ratarg ) { struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { - // TODO: not longer works struct cons_pointer one = make_integer( 1, NIL ), - ratio = make_ratio( intarg, one ); + ratio = make_ratio( frame_pointer, intarg, one ); - result = add_ratio_ratio( ratio, ratarg ); + result = add_ratio_ratio( frame_pointer, ratio, ratarg ); dec_ref( one ); dec_ref( ratio ); @@ -175,7 +182,8 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, ( L"Shouldn't happen: bad arg to add_integer_ratio" ), make_cons( intarg, make_cons( ratarg, - NIL ) ) ), NIL ); + NIL ) ) ), + frame_pointer ); } return result; @@ -187,13 +195,15 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, * @exception will return an exception if either `arg1` or `arg2` is not a * rational number. */ -struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, +struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg1, struct cons_pointer arg2 ) { - // 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 ), result = - multiply_ratio_ratio( arg1, i ); + struct cons_pointer i = make_ratio( frame_pointer, + pointer2cell( arg2 ).payload. + ratio.divisor, + pointer2cell( arg2 ).payload. + ratio.dividend ), result = + multiply_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); @@ -206,10 +216,9 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, * @exception will return an exception if either `arg1` or `arg2` is not a * rational number. */ -struct cons_pointer multiply_ratio_ratio( struct +struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct cons_pointer arg1, struct cons_pointer arg2 ) { - // TODO: this now has to work if arg1 is an integer struct cons_pointer result; debug_print( L"multiply_ratio_ratio( arg1 = ", DEBUG_ARITH ); @@ -232,9 +241,9 @@ struct cons_pointer multiply_ratio_ratio( struct ddrv = dd1v * dd2v, drrv = dr1v * dr2v; struct cons_pointer unsimplified = - make_ratio( make_integer( ddrv, NIL ), + make_ratio( frame_pointer, make_integer( ddrv, NIL ), make_integer( drrv, NIL ) ); - result = simplify_ratio( unsimplified ); + result = simplify_ratio( frame_pointer, unsimplified ); if ( !eq( unsimplified, result ) ) { dec_ref( unsimplified ); @@ -243,7 +252,7 @@ struct cons_pointer multiply_ratio_ratio( struct result = throw_exception( c_string_to_lisp_string ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ), - NIL ); + frame_pointer ); } return result; @@ -255,15 +264,15 @@ struct cons_pointer multiply_ratio_ratio( struct * `ratarg`. * @exception if either `intarg` or `ratarg` is not of the expected type. */ -struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, +struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, + struct cons_pointer intarg, struct cons_pointer ratarg ) { struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { - // TODO: no longer works; fix struct cons_pointer one = make_integer( 1, NIL ), - ratio = make_ratio( intarg, one ); - result = multiply_ratio_ratio( ratio, ratarg ); + ratio = make_ratio( frame_pointer, intarg, one ); + result = multiply_ratio_ratio( frame_pointer, ratio, ratarg ); dec_ref( one ); dec_ref( ratio ); @@ -271,7 +280,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, result = throw_exception( c_string_to_lisp_string ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ), - NIL ); + frame_pointer ); } return result; @@ -284,10 +293,11 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, * @exception will return an exception if either `arg1` or `arg2` is not a * rational number. */ -struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, +struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg1, struct cons_pointer arg2 ) { - struct cons_pointer i = negative( arg2 ), - result = add_ratio_ratio( arg1, i ); + struct cons_pointer i = negative( frame_pointer, arg2 ), + result = add_ratio_ratio( frame_pointer, arg1, i ); dec_ref( i ); @@ -301,13 +311,14 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, * `frame_pointer`. * @exception if either `dividend` or `divisor` is not an integer. */ -struct cons_pointer make_ratio( struct cons_pointer dividend, +struct cons_pointer make_ratio( struct cons_pointer frame_pointer, + struct cons_pointer dividend, struct cons_pointer divisor ) { struct cons_pointer result; if ( integerp( dividend ) && integerp( divisor ) ) { inc_ref( dividend ); inc_ref( divisor ); - result = allocate_cell( RATIOTV ); + result = allocate_cell( RATIOTAG ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.ratio.dividend = dividend; cell->payload.ratio.divisor = divisor; @@ -315,28 +326,10 @@ struct cons_pointer make_ratio( struct cons_pointer dividend, result = throw_exception( c_string_to_lisp_string ( L"Dividend and divisor of a ratio must be integers" ), - NIL ); + frame_pointer ); } debug_dump_object( result, DEBUG_ARITH ); - return result; -} - -/** - * 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; - - if ( ratiop( a ) && ratiop( b ) ) { - struct cons_space_object *cell_a = &pointer2cell( a ); - struct cons_space_object *cell_b = &pointer2cell( b ); - - result = equal_integer_integer( cell_a->payload.ratio.dividend, - cell_b->payload.ratio.dividend ) && - equal_integer_integer( cell_a->payload.ratio.divisor, - cell_b->payload.ratio.divisor ); - } return result; } diff --git a/src/arith/ratio.h b/src/arith/ratio.h index 9068bfb..5a3b0d6 100644 --- a/src/arith/ratio.h +++ b/src/arith/ratio.h @@ -11,29 +11,36 @@ #ifndef __ratio_h #define __ratio_h -struct cons_pointer simplify_ratio( struct cons_pointer arg ); +struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg ); -struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, +struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer add_integer_ratio( struct cons_pointer intarg, +struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, + struct cons_pointer intarg, struct cons_pointer ratarg ); -struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, +struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer multiply_ratio_ratio( struct cons_pointer arg1, struct +struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct + cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, +struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, + struct cons_pointer intarg, struct cons_pointer ratarg ); -struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, +struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, + struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer make_ratio( struct cons_pointer dividend, +struct cons_pointer make_ratio( struct cons_pointer frame_pointer, + struct cons_pointer dividend, struct cons_pointer divisor ); -bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ); #endif diff --git a/src/arith/real.c b/src/arith/real.c index 34d29d0..84ba899 100644 --- a/src/arith/real.c +++ b/src/arith/real.c @@ -7,10 +7,10 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#include "memory/conspage.h" -#include "memory/consspaceobject.h" +#include "conspage.h" +#include "consspaceobject.h" #include "debug.h" -#include "io/read.h" +#include "read.h" /** * Allocate a real number cell representing this value and return a cons @@ -19,7 +19,7 @@ * @return a real number cell wrapping this value. */ struct cons_pointer make_real( long double value ) { - struct cons_pointer result = allocate_cell( REALTV ); + struct cons_pointer result = allocate_cell( REALTAG ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.real.value = value; diff --git a/src/authorise.c b/src/authorise.c deleted file mode 100644 index afd730d..0000000 --- a/src/authorise.c +++ /dev/null @@ -1,24 +0,0 @@ -/* - * authorised.c - * - * For now, a dummy authorising everything. - * - * (c) 2021 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include "memory/conspage.h" -#include "memory/consspaceobject.h" - - -/** - * TODO: does nothing, yet. What it should do is access a magic value in the - * runtime environment and check that it is identical to something on this `acl` - */ -struct cons_pointer authorised( struct cons_pointer target, - struct cons_pointer acl ) { - if ( nilp( acl ) ) { - acl = pointer2cell( target ).access; - } - return TRUE; -} diff --git a/src/authorise.h b/src/authorise.h deleted file mode 100644 index 6c55b32..0000000 --- a/src/authorise.h +++ /dev/null @@ -1,16 +0,0 @@ -/* - * authorise.h - * - * Basic implementation of a authorisation. - * - * (c) 2021 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_authorise_h -#define __psse_authorise_h - -struct cons_pointer authorised( struct cons_pointer target, - struct cons_pointer acl ); - -#endif diff --git a/src/debug.c b/src/debug.c index 233e154..c8b9771 100644 --- a/src/debug.c +++ b/src/debug.c @@ -18,11 +18,11 @@ #include #include -#include "memory/consspaceobject.h" +#include "consspaceobject.h" #include "debug.h" -#include "memory/dump.h" -#include "io/io.h" -#include "io/print.h" +#include "dump.h" +#include "io.h" +#include "print.h" /** * the controlling flags for `debug_print`; set in `init.c`, q.v. diff --git a/src/init.c b/src/init.c index 676964f..dbfdd5d 100644 --- a/src/init.c +++ b/src/init.c @@ -20,20 +20,18 @@ #include #include "version.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "memory/stack.h" +#include "conspage.h" +#include "consspaceobject.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 "intern.h" +#include "io.h" +#include "lispops.h" +#include "map.h" +#include "meta.h" +#include "peano.h" +#include "print.h" #include "repl.h" -#include "io/fopen.h" -#include "time/psse_time.h" +#include "psse_time.h" // extern char *optarg; /* defined in unistd.h */ @@ -86,9 +84,8 @@ void bind_value( wchar_t *name, struct cons_pointer value ) { dec_ref( n ); } -void print_banner( ) { - fwprintf( stdout, L"Post-Scarcity Software Environment version %s\n\n", - VERSION ); +void print_banner() { + fwprintf(stdout, L"Post-Scarcity Software Environment version %s\n\n", VERSION); } /** @@ -96,24 +93,22 @@ void print_banner( ) { * * @stream the stream to print to. */ -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-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n" ); - fwprintf( stream, L"\t\tWhere bits are interpreted as follows:\n" ); - fwprintf( stream, L"\t\t1\tALLOC;\n" ); - fwprintf( stream, L"\t\t2\tARITH;\n" ); - fwprintf( stream, L"\t\t4\tBIND;\n" ); - fwprintf( stream, L"\t\t8\tBOOTSTRAP;\n" ); - fwprintf( stream, L"\t\t16\tEVAL;\n" ); - 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" ); +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-v LEVEL\n\t\tSet verbosity to the specified level (0...512)\n"); + fwprintf(stream, L"\t\tWhere bits are interpreted as follows:\n"); + fwprintf(stream, L"\t\t1\tALLOC;\n"); + fwprintf(stream, L"\t\t2\tARITH;\n"); + fwprintf(stream, L"\t\t4\tBIND;\n"); + fwprintf(stream, L"\t\t8\tBOOTSTRAP;\n"); + fwprintf(stream, L"\t\t16\tEVAL;\n"); + 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"); } /** @@ -137,8 +132,8 @@ int main( int argc, char *argv[] ) { dump_at_end = true; break; case 'h': - print_banner( ); - print_options( stdout ); + print_banner(); + print_options(stdout); exit( 0 ); break; case 'p': @@ -149,14 +144,14 @@ int main( int argc, char *argv[] ) { break; default: fwprintf( stderr, L"Unexpected option %c\n", option ); - print_options( stderr ); + print_options(stderr); exit( 1 ); break; } } if ( show_prompt ) { - print_banner( ); + print_banner(); } debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP ); @@ -165,9 +160,6 @@ int main( int argc, char *argv[] ) { 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) */ @@ -222,7 +214,6 @@ int main( int argc, char *argv[] ) { */ 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 ); @@ -234,12 +225,8 @@ int main( int argc, char *argv[] ) { 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"make-map", &lisp_make_map); bind_function( L"meta", &lisp_metadata ); bind_function( L"metadata", &lisp_metadata ); bind_function( L"multiply", &lisp_multiply ); @@ -247,8 +234,7 @@ int main( int argc, char *argv[] ) { 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"progn", &lisp_progn ); bind_function( L"read", &lisp_read ); bind_function( L"read-char", &lisp_read_char ); bind_function( L"repl", &lisp_repl ); @@ -271,18 +257,14 @@ int main( int argc, char *argv[] ) { 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_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP ); dec_ref( oblist ); debug_dump_object( oblist, DEBUG_BOOTSTRAP ); @@ -290,7 +272,6 @@ int main( int argc, char *argv[] ) { dump_pages( file_to_url_file( stdout ) ); } - summarise_allocation( ); curl_global_cleanup( ); return ( 0 ); } diff --git a/src/io/fopen.c b/src/io/fopen.c index e4fafdd..d3ece5c 100644 --- a/src/io/fopen.c +++ b/src/io/fopen.c @@ -47,12 +47,12 @@ #include -#include "io/fopen.h" +#include "fopen.h" #ifdef FOPEN_STANDALONE CURLSH *io_share; #else -#include "memory/consspaceobject.h" -#include "io/io.h" +#include "consspaceobject.h" +#include "io.h" #include "utils.h" #endif @@ -213,7 +213,7 @@ URL_FILE *url_fopen( const char *url, const char *operation ) { file->handle.file = fopen( url, operation ); if ( file->handle.file ) { file->type = CFTYPE_FILE; /* marked as file */ - } else if ( index_of( ':', url ) > -1 ) { + } else if ( index_of(':', url ) > -1 ) { file->type = CFTYPE_CURL; /* marked as URL */ file->handle.curl = curl_easy_init( ); diff --git a/src/io/io.c b/src/io/io.c index d01f788..5065044 100644 --- a/src/io/io.c +++ b/src/io/io.c @@ -28,13 +28,13 @@ #include -#include "memory/conspage.h" -#include "memory/consspaceobject.h" +#include "conspage.h" +#include "consspaceobject.h" #include "debug.h" -#include "io/fopen.h" -#include "arith/integer.h" -#include "ops/intern.h" -#include "ops/lispops.h" +#include "fopen.h" +#include "integer.h" +#include "intern.h" +#include "lispops.h" #include "utils.h" /** @@ -56,6 +56,8 @@ wint_t ungotten = 0; * @return 0 on success; any other value means failure. */ int io_init( ) { + CURL *curl; + CURLcode res; int result = curl_global_init( CURL_GLOBAL_SSL ); io_share = curl_share_init( ); @@ -164,7 +166,6 @@ wint_t url_fgetwc( URL_FILE * input ) { debug_print( L"url_fgetwc: back from url_fgets\n", DEBUG_IO ); int c = ( int ) cbuff[0]; - // TODO: risk of reading off cbuff? debug_printf( DEBUG_IO, L"url_fgetwc: cbuff is '%s'; (first) character = %d (%c)\n", cbuff, c, c & 0xf7 ); @@ -176,13 +177,13 @@ wint_t url_fgetwc( URL_FILE * input ) { * E0 to EF hex (224 to 239): first byte of a three-byte sequence. * F0 to FF hex (240 to 255): first byte of a four-byte sequence. */ - if ( c <= 0xf7 ) { + if ( c <= 0x07 ) { count = 1; - } else if ( c >= 0xc2 && c <= 0xdf ) { + } else if ( c >= '0xc2' && c <= '0xdf' ) { count = 2; - } else if ( c >= 0xe0 && c <= 0xef ) { + } else if ( c >= '0xe0' && c <= '0xef' ) { count = 3; - } else if ( c >= 0xf0 && c <= 0xff ) { + } else if ( c >= '0xf0' && c <= '0xff' ) { count = 4; } @@ -264,7 +265,7 @@ struct cons_pointer add_meta_integer( struct cons_pointer meta, wchar_t *key, struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key, char *value ) { - value = trim( value ); + value = trim( value); wchar_t buffer[strlen( value ) + 1]; mbstowcs( buffer, value, strlen( value ) + 1 ); @@ -279,8 +280,9 @@ struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key, char datestring[256]; strftime( datestring, - sizeof( datestring ), - nl_langinfo( D_T_FMT ), localtime( value ) ); + sizeof( datestring ), + nl_langinfo( D_T_FMT ), + localtime( value ) ); return add_meta_string( meta, key, datestring ); } @@ -389,28 +391,10 @@ void collect_meta( struct cons_pointer stream, char *url ) { } /* this is destructive change before the cell is released into the - * wild, and consequently permissible, just. */ + * wild, and consequently permissible, just. */ cell->payload.stream.meta = meta; } -/** - * Resutn the current default input, or of `inputp` is false, output stream from - * this `env`ironment. - */ -struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_pointer stream_name = - c_string_to_lisp_symbol( inputp ? L"*in*" : L"*out*" ); - - inc_ref( stream_name ); - - result = c_assoc( stream_name, env ); - - dec_ref( stream_name ); - - return result; -} - /** * Function: return a stream open on the URL indicated by the first argument; @@ -439,23 +423,20 @@ lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, URL_FILE *stream = url_fopen( url, "r" ); debug_printf( DEBUG_IO, - L"lisp_open: stream @ %ld, stream type = %d, stream handle = %ld\n", - ( long int ) &stream, ( int ) stream->type, - ( long int ) stream->handle.file ); + L"lisp_open: stream @ %d, stream type = %d, stream handle = %d\n", + (int) &stream, (int)stream->type, (int)stream->handle.file); - switch ( stream->type ) { + switch (stream->type) { case CFTYPE_NONE: - return - make_exception( c_string_to_lisp_string - ( L"Could not open stream" ), - frame_pointer ); + return make_exception( + c_string_to_lisp_string( L"Could not open stream"), + frame_pointer); break; case CFTYPE_FILE: - if ( stream->handle.file == NULL ) { - return - make_exception( c_string_to_lisp_string - ( L"Could not open file" ), - frame_pointer ); + if (stream->handle.file == NULL) { + return make_exception( + c_string_to_lisp_string( L"Could not open file"), + frame_pointer); } break; case CFTYPE_CURL: @@ -502,8 +483,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; diff --git a/src/io/io.h b/src/io/io.h index f350c13..33f733f 100644 --- a/src/io/io.h +++ b/src/io/io.h @@ -21,8 +21,6 @@ URL_FILE *file_to_url_file( FILE * f ); wint_t url_fgetwc( URL_FILE * input ); wint_t url_ungetwc( wint_t wc, URL_FILE * input ); -struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ); - struct cons_pointer lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); diff --git a/src/io/print.c b/src/io/print.c index 8f4b88e..f0db8cd 100644 --- a/src/io/print.c +++ b/src/io/print.c @@ -17,15 +17,15 @@ #include #include -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "memory/hashmap.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" +#include "conspage.h" +#include "consspaceobject.h" +#include "integer.h" +#include "intern.h" +#include "map.h" +#include "stack.h" +#include "print.h" +#include "psse_time.h" +#include "vectorspace.h" /** * print all the characters in the symbol or string indicated by `pointer` @@ -88,38 +88,40 @@ void print_list( URL_FILE * output, struct cons_pointer pointer ) { url_fputws( L")", output ); } -void print_map( URL_FILE * output, struct cons_pointer map ) { - if ( hashmapp( map ) ) { - struct vector_space_object *vso = pointer_to_vso( map ); - url_fputwc( btowc( '{' ), output ); +void print_map( URL_FILE * output, struct cons_pointer map) { + if ( vectorpointp( map)) { + struct vector_space_object *vso = pointer_to_vso( map); - for ( struct cons_pointer ks = hashmap_keys( map ); !nilp( ks ); - ks = c_cdr( ks ) ) { - struct cons_pointer key = c_car( ks ); - print( output, key ); - url_fputwc( btowc( ' ' ), output ); - print( output, hashmap_get( map, key ) ); + if ( mapp( vso ) ) { + url_fputwc( btowc( '{' ), output ); - if ( !nilp( c_cdr( ks ) ) ) { - url_fputws( L", ", output ); + for ( struct cons_pointer ks = keys( map); + !nilp( ks); ks = c_cdr( ks)) { + print( output, c_car( ks)); + url_fputwc( btowc( ' ' ), output ); + print( output, c_assoc( c_car( ks), map)); + + if ( !nilp( c_cdr( ks))) { + url_fputws( L", ", output ); + } } - } - url_fputwc( btowc( '}' ), output ); + url_fputwc( btowc( '}' ), output ); + } } } -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 ); + +void print_vso( URL_FILE * output, struct cons_pointer pointer) { + struct vector_space_object *vso = + pointer2cell( pointer ).payload.vectorp.address; + + switch ( vso->header.tag.value) { + case MAPTV: + print_map( output, pointer); break; - // \todo: others. - default: - fwprintf( stderr, L"Unrecognised vector-space type '%d'\n", - vso->header.tag.value ); + // \todo: others. } } @@ -130,14 +132,14 @@ void print_128bit( URL_FILE * output, __int128_t n ) { if ( n == 0 ) { fwprintf( stderr, L"0" ); } else { - char str[40] = { 0 }; // log10(1 << 128) + '\0' + char str[40] = { 0 }; // log10(1 << 128) + '\0' char *s = str + sizeof( str ) - 1; // start at the end while ( n != 0 ) { if ( s == str ) - return; // never happens + return; // never happens *--s = "0123456789"[n % 10]; // save last digit - n /= 10; // drop it + n /= 10; // drop it } url_fwprintf( output, L"%s", s ); } @@ -165,9 +167,9 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { dump_stack_trace( output, pointer ); break; case FUNCTIONTV: - url_fputws( L"', output ); + url_fputws( L"', output); break; case INTEGERTV:{ struct cons_pointer s = integer_to_string( pointer, 10 ); @@ -181,9 +183,8 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { print_string_contents( output, pointer ); break; case LAMBDATV:{ - url_fputws( L"', output ); } break; case NILTV: url_fwprintf( output, L"nil" ); break; case NLAMBDATV:{ - url_fputws( L"', output ); } break; case RATIOTV: @@ -218,8 +216,8 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { break; case READTV: url_fwprintf( output, L"', output ); + print( output, cell.payload.stream.meta); + url_fputwc( L'>', output); break; case REALTV: /* \todo using the C heap is a bad plan because it will fragment. @@ -245,26 +243,26 @@ struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { break; case SPECIALTV: url_fwprintf( output, L"', output ); + print( output, cell.payload.special.meta); + url_fputwc( L'>', output); break; case TIMETV: url_fwprintf( output, L"', output ); + print_string( output, time_to_string( pointer)); + url_fputws( L"; ", output); + print_128bit( output, pointer2cell(pointer).payload.time.value); + url_fputwc( L'>', output); break; case TRUETV: url_fwprintf( output, L"t" ); break; case VECTORPOINTTV: - print_vso( output, pointer ); + print_vso( output, pointer); break; case WRITETV: url_fwprintf( output, L"', output ); + print( output, cell.payload.stream.meta); + url_fputwc( L'>', output); break; default: fwprintf( stderr, diff --git a/src/io/read.c b/src/io/read.c index df0735b..4f3ed0a 100644 --- a/src/io/read.c +++ b/src/io/read.c @@ -17,29 +17,25 @@ #include #include -#include "memory/consspaceobject.h" +#include "consspaceobject.h" #include "debug.h" -#include "memory/dump.h" -#include "memory/hashmap.h" -#include "arith/integer.h" -#include "ops/intern.h" -#include "io/io.h" -#include "ops/lispops.h" -#include "arith/peano.h" -#include "io/print.h" -#include "arith/ratio.h" -#include "io/read.h" -#include "arith/real.h" -#include "memory/vectorspace.h" +#include "dump.h" +#include "integer.h" +#include "intern.h" +#include "io.h" +#include "lispops.h" +#include "map.h" +#include "peano.h" +#include "print.h" +#include "ratio.h" +#include "read.h" +#include "real.h" +#include "vectorspace.h" /* - * for the time being things which may be read are: - * * strings - * * numbers - either integer, ratio or real - * * lists - * * maps - * * keywords - * * atoms + * for the time being things which may be read are: strings numbers - either + * integer or real, but not yet including ratios or bignums lists Can't read + * atoms because I don't yet know what an atom is or how it's stored. */ struct cons_pointer read_number( struct stack_frame *frame, @@ -48,14 +44,12 @@ struct cons_pointer read_number( struct stack_frame *frame, bool seen_period ); struct cons_pointer read_list( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env, URL_FILE * input, wint_t initial ); struct cons_pointer read_map( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env, - URL_FILE * input, wint_t initial ); + struct cons_pointer frame_pointer, + URL_FILE * input, wint_t initial ); struct cons_pointer read_string( URL_FILE * input, wint_t initial ); -struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, +struct cons_pointer read_symbol_or_key( URL_FILE * input, char *tag, wint_t initial ); /** @@ -66,77 +60,6 @@ struct cons_pointer c_quote( struct cons_pointer arg ) { make_cons( arg, NIL ) ); } -/** - * Read a path macro from the stream. A path macro is expected to be - * 1. optionally a leading character such as '/' or '$', followed by - * 2. one or more keywords with leading colons (':') but no intervening spaces; or - * 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 q ) { - bool done = false; - struct cons_pointer prefix = NIL; - - switch ( initial ) { - case '/': - prefix = c_string_to_lisp_symbol( L"oblist" ); - break; - case '$': - case L'§': - prefix = c_string_to_lisp_symbol( L"session" ); - break; - } - - while ( !done ) { - wint_t c = url_fgetwc( input ); - if ( iswblank( c ) || iswcntrl( c ) ) { - done = true; - } else if ( url_feof( input ) ) { - done = true; - } else { - switch ( c ) { - case ':': - q = make_cons( read_symbol_or_key - ( input, KEYTV, url_fgetwc( input ) ), q ); - break; - case '/': - q = make_cons( make_cons - ( c_string_to_lisp_symbol( L"quote" ), - make_cons( read_symbol_or_key - ( input, SYMBOLTV, - url_fgetwc( input ) ), - NIL ) ), q ); - break; - default: - if ( iswalpha( c ) ) { - q = make_cons( read_symbol_or_key - ( input, SYMBOLTV, c ), q ); - } else { - // TODO: it's really an error. Exception? - url_ungetwc( c, input ); - done = true; - } - } - } - } - - // right, we now have the path we want (reversed) in q. - struct cons_pointer r = NIL; - - for ( struct cons_pointer p = q; !nilp( p ); p = c_cdr( p ) ) { - r = make_cons( c_car( p ), r ); - } - - dec_ref( q ); - - if ( !nilp( prefix ) ) { - r = make_cons( prefix, r ); - } - - return make_cons( c_string_to_lisp_symbol( L"->" ), r ); -} - /** * Read the next object on this input stream and return a cons_pointer to it, * treating this initial character as the first character of the object @@ -144,7 +67,6 @@ 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 ) { debug_print( L"entering read_continuation\n", DEBUG_IO ); struct cons_pointer result = NIL; @@ -174,17 +96,17 @@ struct cons_pointer read_continuation( struct stack_frame *frame, case '\'': result = c_quote( read_continuation - ( frame, frame_pointer, env, input, + ( frame, frame_pointer, input, url_fgetwc( input ) ) ); break; case '(': result = - read_list( frame, frame_pointer, env, input, + read_list( frame, frame_pointer, input, url_fgetwc( input ) ); break; case '{': - result = read_map( frame, frame_pointer, env, input, - url_fgetwc( input ) ); + result = read_map( frame, frame_pointer, input, + url_fgetwc( input ) ); break; case '"': result = read_string( input, url_fgetwc( input ) ); @@ -197,7 +119,7 @@ struct cons_pointer read_continuation( struct stack_frame *frame, read_number( frame, frame_pointer, input, c, false ); } else { - result = read_symbol_or_key( input, SYMBOLTV, c ); + result = read_symbol_or_key( input, SYMBOLTAG, c ); } } break; @@ -212,48 +134,25 @@ struct cons_pointer read_continuation( struct stack_frame *frame, } else if ( iswblank( next ) ) { /* dotted pair. \todo this isn't right, we * really need to backtrack up a level. */ - result = - read_continuation( frame, frame_pointer, env, - input, url_fgetwc( input ) ); - debug_print - ( L"read_continuation: dotted pair; read cdr ", - DEBUG_IO ); + result = read_continuation( frame, frame_pointer, input, + url_fgetwc( input ) ); + debug_print( L"read_continuation: dotted pair; read cdr ", + DEBUG_IO); } else { - read_symbol_or_key( input, SYMBOLTV, c ); + read_symbol_or_key( input, SYMBOLTAG, c ); } } break; case ':': result = - read_symbol_or_key( input, KEYTV, url_fgetwc( input ) ); - break; - case '/': - { - /* slash followed by whitespace is legit provided it's not - * preceded by anything - it's the division operator. Otherwise, - * it's terminal, probably part of a path, and needs pushed back. - */ - wint_t cn = url_fgetwc( input ); - if ( nilp( result ) - && ( iswblank( cn ) || iswcntrl( cn ) ) ) { - url_ungetwc( cn, input ); - result = make_symbol_or_key( c, NIL, SYMBOLTV ); - } else { - url_ungetwc( cn, input ); - result = read_path( input, c, NIL ); - } - } - break; - case '$': - case L'§': - result = read_path( input, c, NIL ); + read_symbol_or_key( input, KEYTAG, url_fgetwc( input ) ); break; default: if ( iswdigit( c ) ) { result = read_number( frame, frame_pointer, input, c, false ); } else if ( iswprint( c ) ) { - result = read_symbol_or_key( input, SYMBOLTV, c ); + result = read_symbol_or_key( input, SYMBOLTAG, c ); } else { result = throw_exception( make_cons( c_string_to_lisp_string @@ -351,7 +250,7 @@ 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, + struct cons_pointer div = make_ratio( frame_pointer, result, make_integer( powl ( to_long_double ( base ), @@ -364,14 +263,14 @@ 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 ); + result = make_ratio( frame_pointer, dividend, result ); } if ( neg ) { debug_print( L"read_number: converting result to negative\n", DEBUG_IO ); - result = negative( result ); + result = negative( frame_pointer, result ); } debug_print( L"read_number returning\n", DEBUG_IO ); @@ -385,37 +284,37 @@ struct cons_pointer read_number( struct stack_frame *frame, * left parenthesis. */ struct cons_pointer read_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env, - URL_FILE * input, wint_t initial ) { + struct cons_pointer frame_pointer, + URL_FILE * input, wint_t initial ) { struct cons_pointer result = NIL; wint_t c; if ( initial != ')' ) { debug_printf( DEBUG_IO, - L"read_list starting '%C' (%d)\n", initial, initial ); + L"read_list starting '%C' (%d)\n", initial, initial ); struct cons_pointer car = - read_continuation( frame, frame_pointer, env, input, - initial ); + read_continuation( frame, frame_pointer, input, + initial ); /* skip whitespace */ - for ( c = url_fgetwc( input ); - iswblank( c ) || iswcntrl( c ); c = url_fgetwc( input ) ); + for (c = url_fgetwc( input ); + iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input )); - if ( c == L'.' ) { + if ( c == L'.') { /* might be a dotted pair; indeed, if we rule out numbers with * initial periods, it must be a dotted pair. \todo Ought to check, * howerver, that there's only one form after the period. */ result = make_cons( car, - c_car( read_list( frame, - frame_pointer, - env, - input, url_fgetwc( input ) ) ) ); + c_car( read_list( frame, + frame_pointer, + input, + url_fgetwc( input ) ) ) ); } else { result = make_cons( car, - read_list( frame, frame_pointer, env, input, c ) ); + read_list( frame, frame_pointer, input, c ) ); } } else { debug_print( L"End of list detected\n", DEBUG_IO ); @@ -424,42 +323,37 @@ struct cons_pointer read_list( struct stack_frame *frame, return result; } + struct cons_pointer read_map( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env, - 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 ); + struct cons_pointer frame_pointer, + URL_FILE * input, wint_t initial ) { + struct cons_pointer result = make_empty_map( NIL); wint_t c = initial; while ( c != L'}' ) { struct cons_pointer key = - read_continuation( frame, frame_pointer, env, input, c ); + read_continuation( frame, frame_pointer, input, c ); /* skip whitespace */ - for ( c = url_fgetwc( input ); iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input ) ); + for (c = url_fgetwc( input ); + iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input )); struct cons_pointer value = - read_continuation( frame, frame_pointer, env, input, c ); + read_continuation( frame, frame_pointer, input, c ); /* skip commaa and whitespace at this point. */ - for ( c = url_fgetwc( input ); - c == L',' || iswblank( c ) || iswcntrl( c ); - c = url_fgetwc( input ) ); + for (c = url_fgetwc( input ); + c == L',' || iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input )); - result = - hashmap_put( result, key, - eval_form( frame, frame_pointer, value, env ) ); + result = merge_into_map( result, make_cons( make_cons( key, value), NIL)); } - // default write ACL for maps should be NIL. - pointer_to_vso( result )->payload.hashmap.write_acl = NIL; - return result; } + /** * Read a string. This means either a string delimited by double quotes * (is_quoted == true), in which case it may contain whitespace but may @@ -490,7 +384,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, char *tag, wint_t initial ) { struct cons_pointer cdr = NIL; struct cons_pointer result; @@ -503,10 +397,9 @@ struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, /* unwise to allow embedded quotation marks in symbols */ case ')': case ':': - case '/': /* - * symbols and keywords may not include right-parenthesis, - * slashes or colons. + * symbols and keywords may not include right-parenthesis + * or colons. */ result = NIL; /* @@ -545,7 +438,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 ) { - return read_continuation( frame, frame_pointer, env, input, + URL_FILE * input ) { + return read_continuation( frame, frame_pointer, input, url_fgetwc( input ) ); } diff --git a/src/io/read.h b/src/io/read.h index 031bb4f..64f36b0 100644 --- a/src/io/read.h +++ b/src/io/read.h @@ -11,13 +11,11 @@ #ifndef __read_h #define __read_h -#include "memory/consspaceobject.h" - /** * read the next object on this input stream and return a cons_pointer to it. */ struct cons_pointer read( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env, URL_FILE * input ); + URL_FILE * input ); #endif diff --git a/src/memory/conspage.c b/src/memory/conspage.c index f8802cc..2d0958d 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -16,24 +16,18 @@ #include #include -#include "memory/consspaceobject.h" -#include "memory/conspage.h" +#include "consspaceobject.h" +#include "conspage.h" #include "debug.h" -#include "memory/dump.h" -#include "memory/stack.h" -#include "memory/vectorspace.h" +#include "dump.h" +#include "stack.h" +#include "vectorspace.h" /** * Flag indicating whether conspage initialisation has been done. */ bool conspageinitihasbeencalled = false; -/** - * keep track of total cells allocated and freed to check for leakage. - */ -uint64_t total_cells_allocated = 0; -uint64_t total_cells_freed = 0; - /** * the number of cons pages which have thus far been initialised. */ @@ -146,7 +140,7 @@ void free_cell( struct cons_pointer pointer ) { debug_printf( DEBUG_ALLOC, L"Freeing cell " ); debug_dump_object( pointer, DEBUG_ALLOC ); - if ( !check_tag( pointer, FREETV ) ) { + if ( !check_tag( pointer, FREETAG ) ) { if ( cell->count == 0 ) { switch ( cell->tag.value ) { case CONSTV: @@ -154,7 +148,7 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.cons.cdr ); break; case EXCEPTIONTV: - dec_ref( cell->payload.exception.payload ); + dec_ref( cell->payload.exception.message ); dec_ref( cell->payload.exception.frame ); break; case FUNCTIONTV: @@ -185,15 +179,32 @@ void free_cell( struct cons_pointer pointer ) { dec_ref( cell->payload.string.cdr ); break; case VECTORPOINTTV: - free_vso( pointer ); + /* for vector space pointers, free the actual vector-space + * object. Dangerous! */ + debug_printf( DEBUG_ALLOC, + L"About to free vector-space object at 0x%lx\n", + cell->payload.vectorp.address ); + struct vector_space_object *vso = + cell->payload.vectorp.address; + + switch ( vso->header.tag.value ) { + case STACKFRAMETV: + free_stack_frame( get_stack_frame( pointer ) ); + break; + } + + free( ( void * ) cell->payload.vectorp.address ); + debug_printf( DEBUG_ALLOC, + L"Freed vector-space object at 0x%lx\n", + cell->payload.vectorp.address ); break; + } strncpy( &cell->tag.bytes[0], FREETAG, TAGLENGTH ); cell->payload.free.car = NIL; cell->payload.free.cdr = freelist; freelist = pointer; - total_cells_freed++; } else { debug_printf( DEBUG_ALLOC, L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n", @@ -216,7 +227,7 @@ void free_cell( struct cons_pointer pointer ) { * return an exception. Which, as we cannot create such an exception when * cons space is exhausted, means we must construct it at init time. */ -struct cons_pointer allocate_cell( uint32_t tag ) { +struct cons_pointer allocate_cell( char *tag ) { struct cons_pointer result = freelist; @@ -229,16 +240,14 @@ struct cons_pointer allocate_cell( uint32_t tag ) { if ( strncmp( &cell->tag.bytes[0], FREETAG, TAGLENGTH ) == 0 ) { freelist = cell->payload.free.cdr; - cell->tag.value = tag; + strncpy( &cell->tag.bytes[0], tag, TAGLENGTH ); 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 %d, %d \n", tag, + L"Allocated cell of type '%s' at %d, %d \n", tag, result.page, result.offset ); } else { debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" ); @@ -264,9 +273,3 @@ void initialise_cons_pages( ) { L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); } } - -void summarise_allocation( ) { - fwprintf( stderr, - 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 589f6bf..f13a46b 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -13,7 +13,7 @@ #ifndef __psse_conspage_h #define __psse_conspage_h -#include "memory/consspaceobject.h" +#include "consspaceobject.h" /** * the number of cons cells on a cons page. The maximum value this can @@ -55,12 +55,10 @@ extern struct cons_page *conspages[NCONSPAGES]; void free_cell( struct cons_pointer pointer ); -struct cons_pointer allocate_cell( uint32_t tag ); +struct cons_pointer allocate_cell( char *tag ); void initialise_cons_pages( ); void dump_pages( URL_FILE * output ); -void summarise_allocation( ); - #endif diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index 579e84b..344f4ae 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -18,37 +18,19 @@ #include #include -#include "authorise.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" +#include "conspage.h" +#include "consspaceobject.h" #include "debug.h" -#include "ops/intern.h" -#include "io/print.h" -#include "memory/stack.h" -#include "memory/vectorspace.h" +#include "intern.h" +#include "print.h" +#include "stack.h" /** - * True if the value of the tag on the cell at this `pointer` is this `value`, - * or, if the tag of the cell is `VECP`, if the value of the tag of the - * vectorspace object indicated by the cell is this `value`, else false. + * True if the tag on the cell at this `pointer` is this `tag`, else false. */ -bool check_tag( struct cons_pointer pointer, uint32_t value ) { - bool result = false; - +bool check_tag( struct cons_pointer pointer, char *tag ) { struct cons_space_object cell = pointer2cell( pointer ); - result = cell.tag.value == value; - - if ( result == false ) { - if ( cell.tag.value == VECTORPOINTTV ) { - struct vector_space_object *vec = pointer_to_vso( pointer ); - - if ( vec != NULL ) { - result = vec->header.tag.value == value; - } - } - } - - return result; + return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; } /** @@ -56,17 +38,13 @@ 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 ) { +void inc_ref( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); if ( cell->count < MAXREFERENCE ) { cell->count++; } - - return pointer; } /** @@ -74,10 +52,8 @@ 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 ) { +void dec_ref( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); if ( cell->count > 0 ) { @@ -85,11 +61,8 @@ struct cons_pointer dec_ref( struct cons_pointer pointer ) { if ( cell->count == 0 ) { free_cell( pointer ); - pointer = NIL; } } - - return pointer; } @@ -102,31 +75,20 @@ struct cons_pointer c_type( struct cons_pointer pointer ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( pointer ); - 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-- ) { - result = - make_string( ( wchar_t ) vec->header.tag.bytes[i], result ); - } - } else { - for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { - result = make_string( ( wchar_t ) cell.tag.bytes[i], result ); - } + for ( int i = TAGLENGTH - 1; i >= 0; i-- ) { + result = make_string( ( wchar_t ) cell.tag.bytes[i], result ); } return result; } /** - * Implementation of car in C. If arg is not a cons, or the current user is not - * authorised to read it, does not error but returns nil. + * Implementation of car in C. If arg is not a cons, does not error but returns nil. */ struct cons_pointer c_car( struct cons_pointer arg ) { struct cons_pointer result = NIL; - if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) { + if ( consp( arg ) ) { result = pointer2cell( arg ).payload.cons.car; } @@ -134,25 +96,22 @@ 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. + * Implementation of cdr in C. If arg is not a sequence, does not error but returns nil. */ struct cons_pointer c_cdr( struct cons_pointer arg ) { struct cons_pointer result = NIL; - if ( truep( authorised( arg, NIL ) ) ) { - struct cons_space_object *cell = &pointer2cell( arg ); + struct cons_space_object cell = pointer2cell( arg ); - switch ( cell->tag.value ) { - case CONSTV: - result = cell->payload.cons.cdr; - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - result = cell->payload.string.cdr; - break; - } + switch (cell.tag.value) { + case CONSTV: + result = pointer2cell( arg ).payload.cons.cdr; + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + result = pointer2cell( arg ).payload.string.cdr; + break; } return result; @@ -161,11 +120,11 @@ 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. */ -int c_length( struct cons_pointer arg ) { +int c_length( struct cons_pointer arg) { int result = 0; - for ( struct cons_pointer c = arg; !nilp( c ); c = c_cdr( c ) ) { - result++; + for (struct cons_pointer c = arg; !nilp(c); c = c_cdr(c)) { + result ++; } return result; @@ -179,7 +138,7 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr ) { struct cons_pointer pointer = NIL; - pointer = allocate_cell( CONSTV ); + pointer = allocate_cell( CONSTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -199,12 +158,12 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer frame_pointer ) { struct cons_pointer result = NIL; - struct cons_pointer pointer = allocate_cell( EXCEPTIONTV ); + struct cons_pointer pointer = allocate_cell( EXCEPTIONTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( message ); inc_ref( frame_pointer ); - cell->payload.exception.payload = message; + cell->payload.exception.message = message; cell->payload.exception.frame = frame_pointer; result = pointer; @@ -220,7 +179,7 @@ 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_pointer pointer = allocate_cell( FUNCTIONTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( meta ); @@ -235,7 +194,7 @@ make_function( struct cons_pointer meta, struct cons_pointer ( *executable ) */ struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer body ) { - struct cons_pointer pointer = allocate_cell( LAMBDATV ); + struct cons_pointer pointer = allocate_cell( LAMBDATAG ); 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 */ @@ -254,7 +213,7 @@ struct cons_pointer make_lambda( struct cons_pointer args, */ struct cons_pointer make_nlambda( struct cons_pointer args, struct cons_pointer body ) { - struct cons_pointer pointer = allocate_cell( NLAMBDATV ); + struct cons_pointer pointer = allocate_cell( NLAMBDATAG ); 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 */ @@ -267,37 +226,6 @@ struct cons_pointer make_nlambda( struct cons_pointer args, return pointer; } -/** - * 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 - * have that property. - * - * returns 0 for things which are not string like. - */ -uint32_t calculate_hash( wint_t c, struct cons_pointer ptr ) { - struct cons_space_object *cell = &pointer2cell( ptr ); - uint32_t result = 0; - - switch ( cell->tag.value ) { - case KEYTV: - case STRINGTV: - case SYMBOLTV: - if ( nilp( cell->payload.string.cdr ) ) { - result = ( uint32_t ) c; - } else { - result = ( ( uint32_t ) c * - cell->payload.string.hash ) & 0xffffffff; - } - break; - } - - return result; -} - /** * Construct a string from this character (which later will be UTF) and * this tail. A string is implemented as a flat list of cells each of which @@ -305,10 +233,10 @@ uint32_t calculate_hash( wint_t c, struct cons_pointer ptr ) { * pointer to next is NIL. */ struct cons_pointer -make_string_like_thing( wint_t c, struct cons_pointer tail, uint32_t tag ) { +make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { struct cons_pointer pointer = NIL; - if ( check_tag( tail, tag ) || check_tag( tail, NILTV ) ) { + if ( check_tag( tail, tag ) || check_tag( tail, NILTAG ) ) { pointer = allocate_cell( tag ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -317,14 +245,12 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, uint32_t tag ) { 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 = tsil */ cell->payload.string.cdr.offset = tail.offset; - - cell->payload.string.hash = calculate_hash( c, tail ); } else { // \todo should throw an exception! debug_printf( DEBUG_ALLOC, - L"Warning: only NIL and %4.4s can be prepended to %4.4s\n", + L"Warning: only NIL and %s can be prepended to %s\n", tag, tag ); } @@ -340,7 +266,7 @@ make_string_like_thing( wint_t c, struct cons_pointer tail, uint32_t tag ) { * @param tail the string which is being built. */ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { - return make_string_like_thing( c, tail, STRINGTV ); + return make_string_like_thing( c, tail, STRINGTAG ); } /** @@ -352,10 +278,10 @@ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { * @param tag the tag to use: expected to be "SYMB" or "KEYW" */ struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, - uint32_t tag ) { + char *tag ) { struct cons_pointer result = make_string_like_thing( c, tail, tag ); - if ( tag == KEYTV ) { + if ( strncmp( tag, KEYTAG, 4 ) == 0 ) { struct cons_pointer r = internedp( result, oblist ); if ( nilp( r ) ) { @@ -375,7 +301,7 @@ 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_pointer pointer = allocate_cell( SPECIALTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( meta ); @@ -393,7 +319,7 @@ make_special( struct cons_pointer meta, struct cons_pointer ( *executable ) */ struct cons_pointer make_read_stream( URL_FILE * input, struct cons_pointer metadata ) { - struct cons_pointer pointer = allocate_cell( READTV ); + struct cons_pointer pointer = allocate_cell( READTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); cell->payload.stream.stream = input; @@ -410,7 +336,7 @@ struct cons_pointer make_read_stream( URL_FILE * input, */ struct cons_pointer make_write_stream( URL_FILE * output, struct cons_pointer metadata ) { - struct cons_pointer pointer = allocate_cell( WRITETV ); + struct cons_pointer pointer = allocate_cell( WRITETAG ); struct cons_space_object *cell = &pointer2cell( pointer ); cell->payload.stream.stream = output; @@ -426,12 +352,12 @@ struct cons_pointer make_write_stream( URL_FILE * output, struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) { struct cons_pointer result = NIL; - for ( int i = wcslen( symbol ) - 1; i >= 0; i-- ) { - wchar_t c = towlower( symbol[i] ); + for ( int i = wcslen( symbol ) -1; i >= 0; i-- ) { + wchar_t c = towlower(symbol[i]); - if ( iswalnum( c ) || c == L'-' ) { - result = make_keyword( c, result ); - } + if (iswalnum(c) || c == L'-') { + result = make_keyword( c, result ); + } } return result; @@ -444,9 +370,9 @@ struct cons_pointer c_string_to_lisp_string( wchar_t *string ) { struct cons_pointer result = NIL; for ( int i = wcslen( string ) - 1; i >= 0; i-- ) { - if ( iswprint( string[i] ) && string[i] != '"' ) { - result = make_string( string[i], result ); - } + if (iswprint(string[i]) && string[i] != '"') { + result = make_string( string[i], result ); + } } return result; diff --git a/src/memory/consspaceobject.h b/src/memory/consspaceobject.h index 7c3a390..9197172 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -20,8 +20,7 @@ #include #include -#include "io/fopen.h" -// #include "memory/conspage.h" +#include "fopen.h" /** @@ -46,8 +45,7 @@ #define CONSTV 1397641027 /** - * An exception. TODO: we need a means of dealing with different classes of - * exception, and we don't have one yet. + * An exception. */ #define EXCEPTIONTAG "EXEP" @@ -110,17 +108,6 @@ */ #define LAMBDATV 1094995276 -/** - * A loop exit is a special kind of exception which has exactly the same - * payload as an exception. - */ -#define LOOPTAG "LOOP" - -/** - * The string `LOOX`, considered as an `unsigned int`. - */ -#define LOOPTV 1347374924 - /** * The special cons cell at address {0,0} whose car and cdr both point to * itself. @@ -276,114 +263,109 @@ * true if `conspoint` points to the special cell NIL, else false * (there should only be one of these so it's slightly redundant). */ -#define nilp(conspoint) (check_tag(conspoint,NILTV)) +#define nilp(conspoint) (check_tag(conspoint,NILTAG)) /** * true if `conspoint` points to a cons cell, else false */ -#define consp(conspoint) (check_tag(conspoint,CONSTV)) +#define consp(conspoint) (check_tag(conspoint,CONSTAG)) /** * true if `conspoint` points to an exception, else false */ -#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTV)) +#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTAG)) /** * true if `conspoint` points to a function cell, else false */ -#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTV)) +#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG)) /** * true if `conspoint` points to a keyword, else false */ -#define keywordp(conspoint) (check_tag(conspoint,KEYTV)) +#define keywordp(conspoint) (check_tag(conspoint,KEYTAG)) /** - * true if `conspoint` points to a Lambda binding cell, else false + * true if `conspoint` points to a special Lambda cell, else false */ -#define lambdap(conspoint) (check_tag(conspoint,LAMBDATV)) - -/** - * true if `conspoint` points to a loop recursion, else false. - */ -#define loopp(conspoint) (check_tag(conspoint,LOOPTV)) +#define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG)) /** * true if `conspoint` points to a special form cell, else false */ -#define specialp(conspoint) (check_tag(conspoint,SPECIALTV)) +#define specialp(conspoint) (check_tag(conspoint,SPECIALTAG)) /** * true if `conspoint` points to a string cell, else false */ -#define stringp(conspoint) (check_tag(conspoint,STRINGTV)) +#define stringp(conspoint) (check_tag(conspoint,STRINGTAG)) /** * true if `conspoint` points to a symbol cell, else false */ -#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTV)) +#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG)) /** * true if `conspoint` points to an integer cell, else false */ -#define integerp(conspoint) (check_tag(conspoint,INTEGERTV)) +#define integerp(conspoint) (check_tag(conspoint,INTEGERTAG)) /** * true if `conspoint` points to a rational number cell, else false */ -#define ratiop(conspoint) (check_tag(conspoint,RATIOTV)) +#define ratiop(conspoint) (check_tag(conspoint,RATIOTAG)) /** * true if `conspoint` points to a read stream cell, else false */ -#define readp(conspoint) (check_tag(conspoint,READTV)) +#define readp(conspoint) (check_tag(conspoint,READTAG)) /** * true if `conspoint` points to a real number cell, else false */ -#define realp(conspoint) (check_tag(conspoint,REALTV)) +#define realp(conspoint) (check_tag(conspoint,REALTAG)) /** * true if `conspoint` points to some sort of a number cell, * else false */ -#define numberp(conspoint) (check_tag(conspoint,INTEGERTV)||check_tag(conspoint,RATIOTV)||check_tag(conspoint,REALTV)) +#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG)) /** * true if `conspoint` points to a sequence (list, string or, later, vector), * else false. */ -#define sequencep(conspoint) (check_tag(conspoint,CONSTV)||check_tag(conspoint,STRINGTV)||check_tag(conspoint,SYMBOLTV)) +#define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG)) /** * true if `conspoint` points to a vector pointer, else false. */ -#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTV)) +#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTAG)) /** * true if `conspoint` points to a write stream cell, else false. */ -#define writep(conspoint) (check_tag(conspoint,WRITETV)) +#define writep(conspoint) (check_tag(conspoint,WRITETAG)) -#define streamp(conspoint) (check_tag(conspoint,READTV)||check_tag(conspoint,WRITETV)) +#define streamp(conspoint) (check_tag(conspoint,READTAG)||check_tag(conspoint,WRITETAG)) /** * true if `conspoint` points to a true cell, else false * (there should only be one of these so it's slightly redundant). * Also note that anything that is not NIL is truthy. */ -#define tp(conspoint) (check_tag(conspoint,TRUETV)) +#define tp(conspoint) (check_tag(conspoint,TRUETAG)) /** * true if `conspoint` points to a time cell, else false. */ -#define timep(conspoint) (check_tag(conspoint,TIMETV)) +#define timep(conspoint) (check_tag(conspoint,TIMETAG)) /** * true if `conspoint` points to something that is truthy, i.e. * anything but NIL. */ -#define truep(conspoint) (!check_tag(conspoint,NILTV)) +#define truep(conspoint) (!check_tag(conspoint,NILTAG)) /** * An indirect pointer to a cons cell @@ -432,8 +414,8 @@ struct cons_payload { * Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame. */ struct exception_payload { - /** The payload: usually a Lisp string but in practice anything printable will do. */ - struct cons_pointer payload; + /** The message: should be a Lisp string but in practice anything printable will do. */ + struct cons_pointer message; /** pointer to the (unfreed) stack frame in which the exception was thrown. */ struct cons_pointer frame; }; @@ -558,8 +540,8 @@ struct stream_payload { struct string_payload { /** the actual character stored in this cell */ wint_t character; - /** a hash of the string value, computed at store time. */ - uint32_t hash; + /** unused padding to word-align the cdr */ + uint32_t padding; /** the remainder of the string following this character. */ struct cons_pointer cdr; }; @@ -615,7 +597,7 @@ struct cons_space_object { */ struct cons_payload cons; /** - * if tag == EXCEPTIONTAG || tag == LOOPTAG + * if tag == EXCEPTIONTAG */ struct exception_payload exception; /** @@ -673,11 +655,11 @@ struct cons_space_object { } payload; }; -bool check_tag( struct cons_pointer pointer, uint32_t value ); +bool check_tag( struct cons_pointer pointer, char *tag ); -struct cons_pointer inc_ref( struct cons_pointer pointer ); +void inc_ref( struct cons_pointer pointer ); -struct cons_pointer dec_ref( struct cons_pointer pointer ); +void dec_ref( struct cons_pointer pointer ); struct cons_pointer c_type( struct cons_pointer pointer ); @@ -685,7 +667,7 @@ struct cons_pointer c_car( struct cons_pointer arg ); struct cons_pointer c_cdr( struct cons_pointer arg ); -int c_length( struct cons_pointer arg ); +int c_length( struct cons_pointer arg); struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr ); @@ -713,17 +695,14 @@ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer, struct cons_pointer ) ); -struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail, - uint32_t tag ); - 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 ); + char *tag ); -#define make_symbol(c, t) (make_symbol_or_key( c, t, SYMBOLTV)) +#define make_symbol(c, t) (make_symbol_or_key( c, t, SYMBOLTAG)) -#define make_keyword(c, t) (make_symbol_or_key( c, t, KEYTV)) +#define make_keyword(c, t) (make_symbol_or_key( c, t, KEYTAG)) struct cons_pointer make_read_stream( URL_FILE * input, struct cons_pointer metadata ); diff --git a/src/memory/dump.c b/src/memory/dump.c index 2bc5bb0..074d1c4 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -18,15 +18,14 @@ #include #include -#include "memory/conspage.h" -#include "memory/consspaceobject.h" +#include "conspage.h" +#include "consspaceobject.h" #include "debug.h" -#include "memory/hashmap.h" -#include "ops/intern.h" -#include "io/io.h" -#include "io/print.h" -#include "memory/stack.h" -#include "memory/vectorspace.h" +#include "intern.h" +#include "map.h" +#include "print.h" +#include "stack.h" +#include "vectorspace.h" void dump_string_cell( URL_FILE * output, wchar_t *prefix, @@ -40,11 +39,10 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix, cell.payload.string.cdr.offset, cell.count ); } else { url_fwprintf( output, - L"\t\t%ls cell: character '%lc' (%d) with hash %d; next at page %d offset %d, count %u\n", + L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n", prefix, ( wint_t ) cell.payload.string.character, cell.payload.string.character, - cell.payload.string.hash, cell.payload.string.cdr.page, cell.payload.string.cdr.offset, cell.count ); url_fwprintf( output, L"\t\t value: " ); @@ -58,15 +56,15 @@ void dump_string_cell( URL_FILE * output, wchar_t *prefix, */ 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, - cell.count ); + url_fwprintf( output, + L"\t%4.4s (%d) at page %d, offset %d count %u\n", + cell.tag.bytes, + cell.tag.value, pointer.page, pointer.offset, cell.count ); switch ( cell.tag.value ) { case CONSTV: url_fwprintf( output, - L"\t\tCons cell: car at page %d offset %d, cdr at page %d " - L"offset %d, count %u :", + L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u :", cell.payload.cons.car.page, cell.payload.cons.car.offset, cell.payload.cons.cdr.page, @@ -85,16 +83,14 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { cell.payload.cons.cdr.offset ); break; case INTEGERTV: - url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", + url_fwprintf( output, + L"\t\tInteger cell: value %ld, count %u\n", cell.payload.integer.value, cell.count ); if ( !nilp( cell.payload.integer.more ) ) { url_fputws( L"\t\tBIGNUM! More at:\n", output ); dump_object( output, cell.payload.integer.more ); } break; - case KEYTV: - dump_string_cell( output, L"Keyword", pointer ); - break; case LAMBDATV: url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); print( output, cell.payload.lambda.args ); @@ -114,10 +110,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 ); @@ -142,17 +138,18 @@ void dump_object( URL_FILE * output, struct cons_pointer pointer ) { cell.payload.vectorp.address ); struct vector_space_object *vso = cell.payload.vectorp.address; url_fwprintf( output, - L"\t\tVector space object of type %4.4s (%d), payload size " - L"%d bytes\n", + L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n", &vso->header.tag.bytes, vso->header.tag.value, vso->header.size ); - + if ( stackframep( vso ) ) { + dump_frame( output, pointer ); + } switch ( vso->header.tag.value ) { case STACKFRAMETV: dump_frame( output, pointer ); break; - case HASHTV: - dump_map( output, pointer ); + case MAPTV: + dump_map( output, pointer); break; } } diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c deleted file mode 100644 index 5e1db0a..0000000 --- a/src/memory/hashmap.c +++ /dev/null @@ -1,356 +0,0 @@ -/* - * hashmap.c - * - * Basic implementation of a hashmap. - * - * (c) 2021 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include "arith/integer.h" -#include "arith/peano.h" -#include "authorise.h" -#include "debug.h" -#include "ops/intern.h" -#include "io/print.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#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.. - */ -struct cons_pointer lisp_get_hash( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - 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 - * - * first is expected to be an integer, the number of buckets, or nil; - * second is expected to be a hashing function, or nil; - * third is expected to be an assocable, or nil; - * fourth is a list of user tokens, to be used as a write ACL, or nil. - */ -struct cons_pointer lisp_make_hashmap( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - uint32_t n = DFLT_HASHMAP_BUCKETS; - struct cons_pointer hash_fn = NIL; - struct cons_pointer result = NIL; - - if ( frame->args > 0 ) { - if ( integerp( frame->arg[0] ) ) { - n = to_long_int( frame->arg[0] ) % UINT32_MAX; - } else if ( !nilp( frame->arg[0] ) ) { - result = - make_exception( c_string_to_lisp_string - ( L"First arg to `hashmap`, if passed, must " - L"be an integer or `nil`.`" ), NIL ); - } - } - if ( frame->args > 1 ) { - hash_fn = frame->arg[1]; - } - - if ( nilp( result ) ) { - /* if there are fewer than 4 args, then arg[3] ought to be nil anyway, which - * is fine */ - result = make_hashmap( n, hash_fn, frame->arg[3] ); - struct vector_space_object *map = pointer_to_vso( result ); - - if ( frame->args > 2 && - truep( authorised( result, map->payload.hashmap.write_acl ) ) ) { - // then arg[2] ought to be an assoc list which we should iterate down - // populating the hashmap. - for ( struct cons_pointer cursor = frame->arg[2]; !nilp( cursor ); - cursor = c_cdr( cursor ) ) { - struct cons_pointer pair = c_car( cursor ); - struct cons_pointer key = c_car( pair ); - struct cons_pointer val = c_cdr( pair ); - - uint32_t bucket_no = - get_hash( key ) % ( ( struct hashmap_payload * ) - &( map->payload ) )->n_buckets; - - map->payload.hashmap.buckets[bucket_no] = - inc_ref( make_cons( make_cons( key, val ), - map->payload.hashmap. - buckets[bucket_no] ) ); - } - } - } - - 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 - * any value. 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 lisp_hashmap_put( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer mapp = frame->arg[0]; - struct cons_pointer key = frame->arg[1]; - struct cons_pointer val = frame->arg[2]; - - return hashmap_put( mapp, key, val ); -} - -/** - * 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; -} - -/** - * Lisp function expecting two arguments, a hashmap and an assoc list. Copies all - * key/value pairs from the assoc list into the map. - */ -struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - 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 ) { - struct hashmap_payload *payload = - &pointer_to_vso( pointer )->payload.hashmap; - url_fwprintf( output, L"Hashmap with %d buckets:\n", payload->n_buckets ); - url_fwprintf( output, L"\tHash function: " ); - print( output, payload->hash_fn ); - url_fwprintf( output, L"\n\tWrite ACL: " ); - print( output, payload->write_acl ); - url_fwprintf( output, L"\n\tBuckets:" ); - for ( int i = 0; i < payload->n_buckets; i++ ) { - url_fwprintf( output, L"\n\t\t[%d]: ", i ); - print( output, payload->buckets[i] ); - } - url_fwprintf( output, L"\n" ); -} diff --git a/src/memory/hashmap.h b/src/memory/hashmap.h deleted file mode 100644 index b6c4a74..0000000 --- a/src/memory/hashmap.h +++ /dev/null @@ -1,55 +0,0 @@ -/* - * hashmap.h - * - * Basic implementation of a hashmap. - * - * (c) 2021 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __psse_hashmap_h -#define __psse_hashmap_h - -#include "arith/integer.h" -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "memory/vectorspace.h" - -#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 ); - -struct cons_pointer lisp_hashmap_put_all( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -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 359cff2..006d513 100644 --- a/src/memory/lookup3.c +++ b/src/memory/lookup3.c @@ -35,12 +35,12 @@ on 1 byte), but shoehorning those bytes into integers efficiently is messy. */ // #define SELF_TEST 1 -#include /* defines printf for tests */ -#include /* defines time_t for timings in the test */ -#include /* defines uint32_t etc */ -#include /* attempt to define endianness */ +#include /* defines printf for tests */ +#include /* defines time_t for timings in the test */ +#include /* defines uint32_t etc */ +#include /* attempt to define endianness */ #ifdef linux -#include /* attempt to define endianness */ +# include /* attempt to define endianness */ #endif /* @@ -51,16 +51,16 @@ on 1 byte), but shoehorning those bytes into integers efficiently is messy. __BYTE_ORDER == __LITTLE_ENDIAN) || \ (defined(i386) || defined(__i386__) || defined(__i486__) || \ defined(__i586__) || defined(__i686__) || defined(vax) || defined(MIPSEL)) -#define HASH_LITTLE_ENDIAN 1 -#define HASH_BIG_ENDIAN 0 +# define HASH_LITTLE_ENDIAN 1 +# define HASH_BIG_ENDIAN 0 #elif (defined(__BYTE_ORDER) && defined(__BIG_ENDIAN) && \ __BYTE_ORDER == __BIG_ENDIAN) || \ (defined(sparc) || defined(POWERPC) || defined(mc68000) || defined(sel)) -#define HASH_LITTLE_ENDIAN 0 -#define HASH_BIG_ENDIAN 1 +# define HASH_LITTLE_ENDIAN 0 +# define HASH_BIG_ENDIAN 1 #else -#define HASH_LITTLE_ENDIAN 0 -#define HASH_BIG_ENDIAN 0 +# define HASH_LITTLE_ENDIAN 0 +# define HASH_BIG_ENDIAN 0 #endif #define hashsize(n) ((uint32_t)1<<(n)) @@ -170,38 +170,39 @@ 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 */ - 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; +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; - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ( ( ( uint32_t ) length ) << 2 ) + initval; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + (((uint32_t)length)<<2) + initval; /*------------------------------------------------- handle most of the key */ - while ( length > 3 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 3; - k += 3; - } + while (length > 3) + { + a += k[0]; + b += k[1]; + c += k[2]; + mix(a,b,c); + length -= 3; + k += 3; + } /*------------------------------------------- handle the last 3 uint32_t's */ - switch ( length ) { /* all the case statements fall through */ - case 3: - c += k[2]; - case 2: - b += k[1]; - case 1: - a += k[0]; - final( a, b, c ); - case 0: /* case 0: nothing left to add */ - break; - } + switch(length) /* all the case statements fall through */ + { + case 3 : c+=k[2]; + case 2 : b+=k[1]; + case 1 : a+=k[0]; + final(a,b,c); + case 0: /* case 0: nothing left to add */ + break; + } /*------------------------------------------------------ report the result */ - return c; + return c; } @@ -213,41 +214,41 @@ 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 */ - 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 a, b, c; +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 a,b,c; - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ( ( uint32_t ) ( length << 2 ) ) + *pc; - c += *pb; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ((uint32_t)(length<<2)) + *pc; + c += *pb; /*------------------------------------------------- handle most of the key */ - while ( length > 3 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 3; - k += 3; - } + while (length > 3) + { + a += k[0]; + b += k[1]; + c += k[2]; + mix(a,b,c); + length -= 3; + k += 3; + } /*------------------------------------------- handle the last 3 uint32_t's */ - switch ( length ) { /* all the case statements fall through */ - case 3: - c += k[2]; - case 2: - b += k[1]; - case 1: - a += k[0]; - final( a, b, c ); - case 0: /* case 0: nothing left to add */ - break; - } + switch(length) /* all the case statements fall through */ + { + case 3 : c+=k[2]; + case 2 : b+=k[1]; + case 1 : a+=k[0]; + final(a,b,c); + case 0: /* case 0: nothing left to add */ + break; + } /*------------------------------------------------------ report the result */ - *pc = c; - *pb = b; + *pc=c; *pb=b; } @@ -278,251 +279,173 @@ acceptable. Do NOT use for cryptographic purposes. ------------------------------------------------------------------------------- */ -uint32_t hashlittle( const void *key, size_t length, uint32_t initval ) { - uint32_t a, b, c; /* internal state */ - union { - const void *ptr; - size_t i; - } u; /* needed for Mac Powerbook G4 */ +uint32_t hashlittle( const void *key, size_t length, uint32_t initval) +{ + uint32_t a,b,c; /* internal state */ + union { const void *ptr; size_t i; } u; /* needed for Mac Powerbook G4 */ - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ( ( uint32_t ) length ) + initval; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ((uint32_t)length) + initval; - u.ptr = key; - if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x3 ) == 0 ) ) { - const uint32_t *k = ( const uint32_t * ) key; /* read 32-bit chunks */ - const uint8_t *k8; + u.ptr = key; + if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) { + const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */ + const uint8_t *k8; /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 12; - k += 3; - } + while (length > 12) + { + a += k[0]; + b += k[1]; + c += k[2]; + mix(a,b,c); + length -= 12; + k += 3; + } /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]&0xffffff" actually reads beyond the end of the string, but - * then masks off the part it's not allowed to read. Because the - * string is aligned, the masked-off tail is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ + /* + * "k[2]&0xffffff" actually reads beyond the end of the string, but + * then masks off the part it's not allowed to read. Because the + * string is aligned, the masked-off tail is in the same word as the + * rest of the string. Every machine with memory protection I've seen + * does it on word boundaries, so is OK with this. But VALGRIND will + * still catch it and complain. The masking trick does make the hash + * noticably faster for short strings (like English words). + */ #ifndef VALGRIND - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += k[2] & 0xffffff; - b += k[1]; - a += k[0]; - break; - case 10: - c += k[2] & 0xffff; - b += k[1]; - a += k[0]; - break; - case 9: - c += k[2] & 0xff; - b += k[1]; - a += k[0]; - break; - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += k[1] & 0xffffff; - a += k[0]; - break; - case 6: - b += k[1] & 0xffff; - a += k[0]; - break; - case 5: - b += k[1] & 0xff; - a += k[0]; - break; - case 4: - a += k[0]; - break; - case 3: - a += k[0] & 0xffffff; - break; - case 2: - a += k[0] & 0xffff; - break; - case 1: - a += k[0] & 0xff; - break; - case 0: - return c; /* zero length strings require no mixing */ - } + switch(length) + { + case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; + case 11: c+=k[2]&0xffffff; b+=k[1]; a+=k[0]; break; + case 10: c+=k[2]&0xffff; b+=k[1]; a+=k[0]; break; + case 9 : c+=k[2]&0xff; b+=k[1]; a+=k[0]; break; + case 8 : b+=k[1]; a+=k[0]; break; + case 7 : b+=k[1]&0xffffff; a+=k[0]; break; + case 6 : b+=k[1]&0xffff; a+=k[0]; break; + case 5 : b+=k[1]&0xff; a+=k[0]; break; + case 4 : a+=k[0]; break; + case 3 : a+=k[0]&0xffffff; break; + case 2 : a+=k[0]&0xffff; break; + case 1 : a+=k[0]&0xff; break; + case 0 : return c; /* zero length strings require no mixing */ + } #else /* make valgrind happy */ - k8 = ( const uint8_t * ) k; - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ - case 10: - c += ( ( uint32_t ) k8[9] ) << 8; /* fall through */ - case 9: - c += k8[8]; /* fall through */ - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ - case 6: - b += ( ( uint32_t ) k8[5] ) << 8; /* fall through */ - case 5: - b += k8[4]; /* fall through */ - case 4: - a += k[0]; - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ - case 2: - a += ( ( uint32_t ) k8[1] ) << 8; /* fall through */ - case 1: - a += k8[0]; - break; - case 0: - return c; - } + k8 = (const uint8_t *)k; + switch(length) + { + case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; + case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ + case 10: c+=((uint32_t)k8[9])<<8; /* fall through */ + case 9 : c+=k8[8]; /* fall through */ + case 8 : b+=k[1]; a+=k[0]; break; + case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ + case 6 : b+=((uint32_t)k8[5])<<8; /* fall through */ + case 5 : b+=k8[4]; /* fall through */ + case 4 : a+=k[0]; break; + case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ + case 2 : a+=((uint32_t)k8[1])<<8; /* fall through */ + case 1 : a+=k8[0]; break; + case 0 : return c; + } #endif /* !valgrind */ - } else if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x1 ) == 0 ) ) { - const uint16_t *k = ( const uint16_t * ) key; /* read 16-bit chunks */ - const uint8_t *k8; + } else if (HASH_LITTLE_ENDIAN && ((u.i & 0x1) == 0)) { + const uint16_t *k = (const uint16_t *)key; /* read 16-bit chunks */ + const uint8_t *k8; /*--------------- all but last block: aligned reads and different mixing */ - while ( length > 12 ) { - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); - mix( a, b, c ); - length -= 12; - k += 6; - } - - /*----------------------------- handle the last (probably partial) block */ - k8 = ( const uint8_t * ) k; - switch ( length ) { - case 12: - c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ - case 10: - c += k[4]; - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 9: - c += k8[8]; /* fall through */ - case 8: - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ - case 6: - b += k[2]; - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 5: - b += k8[4]; /* fall through */ - case 4: - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ - case 2: - a += k[0]; - break; - case 1: - a += k8[0]; - break; - case 0: - return c; /* zero length requires no mixing */ - } - - } else { /* need to read the key one byte at a time */ - const uint8_t *k = ( const uint8_t * ) key; - - /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += k[0]; - a += ( ( uint32_t ) k[1] ) << 8; - a += ( ( uint32_t ) k[2] ) << 16; - a += ( ( uint32_t ) k[3] ) << 24; - b += k[4]; - b += ( ( uint32_t ) k[5] ) << 8; - b += ( ( uint32_t ) k[6] ) << 16; - b += ( ( uint32_t ) k[7] ) << 24; - c += k[8]; - c += ( ( uint32_t ) k[9] ) << 8; - c += ( ( uint32_t ) k[10] ) << 16; - c += ( ( uint32_t ) k[11] ) << 24; - mix( a, b, c ); - length -= 12; - k += 12; - } - - /*-------------------------------- last block: affect all 32 bits of (c) */ - switch ( length ) { /* all the case statements fall through */ - case 12: - c += ( ( uint32_t ) k[11] ) << 24; - case 11: - c += ( ( uint32_t ) k[10] ) << 16; - case 10: - c += ( ( uint32_t ) k[9] ) << 8; - case 9: - c += k[8]; - case 8: - b += ( ( uint32_t ) k[7] ) << 24; - case 7: - b += ( ( uint32_t ) k[6] ) << 16; - case 6: - b += ( ( uint32_t ) k[5] ) << 8; - case 5: - b += k[4]; - case 4: - a += ( ( uint32_t ) k[3] ) << 24; - case 3: - a += ( ( uint32_t ) k[2] ) << 16; - case 2: - a += ( ( uint32_t ) k[1] ) << 8; - case 1: - a += k[0]; - break; - case 0: - return c; - } + while (length > 12) + { + a += k[0] + (((uint32_t)k[1])<<16); + b += k[2] + (((uint32_t)k[3])<<16); + c += k[4] + (((uint32_t)k[5])<<16); + mix(a,b,c); + length -= 12; + k += 6; } - final( a, b, c ); - return c; + /*----------------------------- handle the last (probably partial) block */ + k8 = (const uint8_t *)k; + switch(length) + { + case 12: c+=k[4]+(((uint32_t)k[5])<<16); + b+=k[2]+(((uint32_t)k[3])<<16); + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ + case 10: c+=k[4]; + b+=k[2]+(((uint32_t)k[3])<<16); + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 9 : c+=k8[8]; /* fall through */ + case 8 : b+=k[2]+(((uint32_t)k[3])<<16); + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ + case 6 : b+=k[2]; + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 5 : b+=k8[4]; /* fall through */ + case 4 : a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ + case 2 : a+=k[0]; + break; + case 1 : a+=k8[0]; + break; + case 0 : return c; /* zero length requires no mixing */ + } + + } else { /* need to read the key one byte at a time */ + const uint8_t *k = (const uint8_t *)key; + + /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ + while (length > 12) + { + a += k[0]; + a += ((uint32_t)k[1])<<8; + a += ((uint32_t)k[2])<<16; + a += ((uint32_t)k[3])<<24; + b += k[4]; + b += ((uint32_t)k[5])<<8; + b += ((uint32_t)k[6])<<16; + b += ((uint32_t)k[7])<<24; + c += k[8]; + c += ((uint32_t)k[9])<<8; + c += ((uint32_t)k[10])<<16; + c += ((uint32_t)k[11])<<24; + mix(a,b,c); + length -= 12; + k += 12; + } + + /*-------------------------------- last block: affect all 32 bits of (c) */ + switch(length) /* all the case statements fall through */ + { + case 12: c+=((uint32_t)k[11])<<24; + case 11: c+=((uint32_t)k[10])<<16; + case 10: c+=((uint32_t)k[9])<<8; + case 9 : c+=k[8]; + case 8 : b+=((uint32_t)k[7])<<24; + case 7 : b+=((uint32_t)k[6])<<16; + case 6 : b+=((uint32_t)k[5])<<8; + case 5 : b+=k[4]; + case 4 : a+=((uint32_t)k[3])<<24; + case 3 : a+=((uint32_t)k[2])<<16; + case 2 : a+=((uint32_t)k[1])<<8; + case 1 : a+=k[0]; + break; + case 0 : return c; + } + } + + final(a,b,c); + return c; } @@ -536,264 +459,178 @@ uint32_t hashlittle( const void *key, size_t length, uint32_t initval ) { * the key. *pc is better mixed than *pb, so use *pc first. If you want * a 64-bit value do something like "*pc + (((uint64_t)*pb)<<32)". */ -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 a, b, c; /* internal state */ - union { - const void *ptr; - size_t i; - } u; /* needed for Mac Powerbook G4 */ +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 a,b,c; /* internal state */ + union { const void *ptr; size_t i; } u; /* needed for Mac Powerbook G4 */ - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ( ( uint32_t ) length ) + *pc; - c += *pb; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ((uint32_t)length) + *pc; + c += *pb; - u.ptr = key; - if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x3 ) == 0 ) ) { - const uint32_t *k = ( const uint32_t * ) key; /* read 32-bit chunks */ - const uint8_t *k8; + u.ptr = key; + if (HASH_LITTLE_ENDIAN && ((u.i & 0x3) == 0)) { + const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */ + const uint8_t *k8; /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 12; - k += 3; - } + while (length > 12) + { + a += k[0]; + b += k[1]; + c += k[2]; + mix(a,b,c); + length -= 12; + k += 3; + } /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]&0xffffff" actually reads beyond the end of the string, but - * then masks off the part it's not allowed to read. Because the - * string is aligned, the masked-off tail is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ + /* + * "k[2]&0xffffff" actually reads beyond the end of the string, but + * then masks off the part it's not allowed to read. Because the + * string is aligned, the masked-off tail is in the same word as the + * rest of the string. Every machine with memory protection I've seen + * does it on word boundaries, so is OK with this. But VALGRIND will + * still catch it and complain. The masking trick does make the hash + * noticably faster for short strings (like English words). + */ #ifndef VALGRIND - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += k[2] & 0xffffff; - b += k[1]; - a += k[0]; - break; - case 10: - c += k[2] & 0xffff; - b += k[1]; - a += k[0]; - break; - case 9: - c += k[2] & 0xff; - b += k[1]; - a += k[0]; - break; - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += k[1] & 0xffffff; - a += k[0]; - break; - case 6: - b += k[1] & 0xffff; - a += k[0]; - break; - case 5: - b += k[1] & 0xff; - a += k[0]; - break; - case 4: - a += k[0]; - break; - case 3: - a += k[0] & 0xffffff; - break; - case 2: - a += k[0] & 0xffff; - break; - case 1: - a += k[0] & 0xff; - break; - case 0: - *pc = c; - *pb = b; - return; /* zero length strings require no mixing */ - } + switch(length) + { + case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; + case 11: c+=k[2]&0xffffff; b+=k[1]; a+=k[0]; break; + case 10: c+=k[2]&0xffff; b+=k[1]; a+=k[0]; break; + case 9 : c+=k[2]&0xff; b+=k[1]; a+=k[0]; break; + case 8 : b+=k[1]; a+=k[0]; break; + case 7 : b+=k[1]&0xffffff; a+=k[0]; break; + case 6 : b+=k[1]&0xffff; a+=k[0]; break; + case 5 : b+=k[1]&0xff; a+=k[0]; break; + case 4 : a+=k[0]; break; + case 3 : a+=k[0]&0xffffff; break; + case 2 : a+=k[0]&0xffff; break; + case 1 : a+=k[0]&0xff; break; + case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ + } #else /* make valgrind happy */ - k8 = ( const uint8_t * ) k; - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ - case 10: - c += ( ( uint32_t ) k8[9] ) << 8; /* fall through */ - case 9: - c += k8[8]; /* fall through */ - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ - case 6: - b += ( ( uint32_t ) k8[5] ) << 8; /* fall through */ - case 5: - b += k8[4]; /* fall through */ - case 4: - a += k[0]; - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ - case 2: - a += ( ( uint32_t ) k8[1] ) << 8; /* fall through */ - case 1: - a += k8[0]; - break; - case 0: - *pc = c; - *pb = b; - return; /* zero length strings require no mixing */ - } + k8 = (const uint8_t *)k; + switch(length) + { + case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; + case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ + case 10: c+=((uint32_t)k8[9])<<8; /* fall through */ + case 9 : c+=k8[8]; /* fall through */ + case 8 : b+=k[1]; a+=k[0]; break; + case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ + case 6 : b+=((uint32_t)k8[5])<<8; /* fall through */ + case 5 : b+=k8[4]; /* fall through */ + case 4 : a+=k[0]; break; + case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ + case 2 : a+=((uint32_t)k8[1])<<8; /* fall through */ + case 1 : a+=k8[0]; break; + case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ + } #endif /* !valgrind */ - } else if ( HASH_LITTLE_ENDIAN && ( ( u.i & 0x1 ) == 0 ) ) { - const uint16_t *k = ( const uint16_t * ) key; /* read 16-bit chunks */ - const uint8_t *k8; + } else if (HASH_LITTLE_ENDIAN && ((u.i & 0x1) == 0)) { + const uint16_t *k = (const uint16_t *)key; /* read 16-bit chunks */ + const uint8_t *k8; /*--------------- all but last block: aligned reads and different mixing */ - while ( length > 12 ) { - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); - mix( a, b, c ); - length -= 12; - k += 6; - } - - /*----------------------------- handle the last (probably partial) block */ - k8 = ( const uint8_t * ) k; - switch ( length ) { - case 12: - c += k[4] + ( ( ( uint32_t ) k[5] ) << 16 ); - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 16; /* fall through */ - case 10: - c += k[4]; - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 9: - c += k8[8]; /* fall through */ - case 8: - b += k[2] + ( ( ( uint32_t ) k[3] ) << 16 ); - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 16; /* fall through */ - case 6: - b += k[2]; - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 5: - b += k8[4]; /* fall through */ - case 4: - a += k[0] + ( ( ( uint32_t ) k[1] ) << 16 ); - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 16; /* fall through */ - case 2: - a += k[0]; - break; - case 1: - a += k8[0]; - break; - case 0: - *pc = c; - *pb = b; - return; /* zero length strings require no mixing */ - } - - } else { /* need to read the key one byte at a time */ - const uint8_t *k = ( const uint8_t * ) key; - - /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += k[0]; - a += ( ( uint32_t ) k[1] ) << 8; - a += ( ( uint32_t ) k[2] ) << 16; - a += ( ( uint32_t ) k[3] ) << 24; - b += k[4]; - b += ( ( uint32_t ) k[5] ) << 8; - b += ( ( uint32_t ) k[6] ) << 16; - b += ( ( uint32_t ) k[7] ) << 24; - c += k[8]; - c += ( ( uint32_t ) k[9] ) << 8; - c += ( ( uint32_t ) k[10] ) << 16; - c += ( ( uint32_t ) k[11] ) << 24; - mix( a, b, c ); - length -= 12; - k += 12; - } - - /*-------------------------------- last block: affect all 32 bits of (c) */ - switch ( length ) { /* all the case statements fall through */ - case 12: - c += ( ( uint32_t ) k[11] ) << 24; - case 11: - c += ( ( uint32_t ) k[10] ) << 16; - case 10: - c += ( ( uint32_t ) k[9] ) << 8; - case 9: - c += k[8]; - case 8: - b += ( ( uint32_t ) k[7] ) << 24; - case 7: - b += ( ( uint32_t ) k[6] ) << 16; - case 6: - b += ( ( uint32_t ) k[5] ) << 8; - case 5: - b += k[4]; - case 4: - a += ( ( uint32_t ) k[3] ) << 24; - case 3: - a += ( ( uint32_t ) k[2] ) << 16; - case 2: - a += ( ( uint32_t ) k[1] ) << 8; - case 1: - a += k[0]; - break; - case 0: - *pc = c; - *pb = b; - return; /* zero length strings require no mixing */ - } + while (length > 12) + { + a += k[0] + (((uint32_t)k[1])<<16); + b += k[2] + (((uint32_t)k[3])<<16); + c += k[4] + (((uint32_t)k[5])<<16); + mix(a,b,c); + length -= 12; + k += 6; } - final( a, b, c ); - *pc = c; - *pb = b; + /*----------------------------- handle the last (probably partial) block */ + k8 = (const uint8_t *)k; + switch(length) + { + case 12: c+=k[4]+(((uint32_t)k[5])<<16); + b+=k[2]+(((uint32_t)k[3])<<16); + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 11: c+=((uint32_t)k8[10])<<16; /* fall through */ + case 10: c+=k[4]; + b+=k[2]+(((uint32_t)k[3])<<16); + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 9 : c+=k8[8]; /* fall through */ + case 8 : b+=k[2]+(((uint32_t)k[3])<<16); + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 7 : b+=((uint32_t)k8[6])<<16; /* fall through */ + case 6 : b+=k[2]; + a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 5 : b+=k8[4]; /* fall through */ + case 4 : a+=k[0]+(((uint32_t)k[1])<<16); + break; + case 3 : a+=((uint32_t)k8[2])<<16; /* fall through */ + case 2 : a+=k[0]; + break; + case 1 : a+=k8[0]; + break; + case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ + } + + } else { /* need to read the key one byte at a time */ + const uint8_t *k = (const uint8_t *)key; + + /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ + while (length > 12) + { + a += k[0]; + a += ((uint32_t)k[1])<<8; + a += ((uint32_t)k[2])<<16; + a += ((uint32_t)k[3])<<24; + b += k[4]; + b += ((uint32_t)k[5])<<8; + b += ((uint32_t)k[6])<<16; + b += ((uint32_t)k[7])<<24; + c += k[8]; + c += ((uint32_t)k[9])<<8; + c += ((uint32_t)k[10])<<16; + c += ((uint32_t)k[11])<<24; + mix(a,b,c); + length -= 12; + k += 12; + } + + /*-------------------------------- last block: affect all 32 bits of (c) */ + switch(length) /* all the case statements fall through */ + { + case 12: c+=((uint32_t)k[11])<<24; + case 11: c+=((uint32_t)k[10])<<16; + case 10: c+=((uint32_t)k[9])<<8; + case 9 : c+=k[8]; + case 8 : b+=((uint32_t)k[7])<<24; + case 7 : b+=((uint32_t)k[6])<<16; + case 6 : b+=((uint32_t)k[5])<<8; + case 5 : b+=k[4]; + case 4 : a+=((uint32_t)k[3])<<24; + case 3 : a+=((uint32_t)k[2])<<16; + case 2 : a+=((uint32_t)k[1])<<8; + case 1 : a+=k[0]; + break; + case 0 : *pc=c; *pb=b; return; /* zero length strings require no mixing */ + } + } + + final(a,b,c); + *pc=c; *pb=b; } @@ -804,214 +641,147 @@ void hashlittle2( const void *key, /* the key to hash */ * from hashlittle() on all machines. hashbig() takes advantage of * big-endian byte ordering. */ -uint32_t hashbig( const void *key, size_t length, uint32_t initval ) { - uint32_t a, b, c; - union { - const void *ptr; - size_t i; - } u; /* to cast key to (size_t) happily */ +uint32_t hashbig( const void *key, size_t length, uint32_t initval) +{ + uint32_t a,b,c; + union { const void *ptr; size_t i; } u; /* to cast key to (size_t) happily */ - /* Set up the internal state */ - a = b = c = 0xdeadbeef + ( ( uint32_t ) length ) + initval; + /* Set up the internal state */ + a = b = c = 0xdeadbeef + ((uint32_t)length) + initval; - u.ptr = key; - if ( HASH_BIG_ENDIAN && ( ( u.i & 0x3 ) == 0 ) ) { - const uint32_t *k = ( const uint32_t * ) key; /* read 32-bit chunks */ - const uint8_t *k8; + u.ptr = key; + if (HASH_BIG_ENDIAN && ((u.i & 0x3) == 0)) { + const uint32_t *k = (const uint32_t *)key; /* read 32-bit chunks */ + const uint8_t *k8; /*------ all but last block: aligned reads and affect 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += k[0]; - b += k[1]; - c += k[2]; - mix( a, b, c ); - length -= 12; - k += 3; - } + while (length > 12) + { + a += k[0]; + b += k[1]; + c += k[2]; + mix(a,b,c); + length -= 12; + k += 3; + } /*----------------------------- handle the last (probably partial) block */ - /* - * "k[2]<<8" actually reads beyond the end of the string, but - * then shifts out the part it's not allowed to read. Because the - * string is aligned, the illegal read is in the same word as the - * rest of the string. Every machine with memory protection I've seen - * does it on word boundaries, so is OK with this. But VALGRIND will - * still catch it and complain. The masking trick does make the hash - * noticably faster for short strings (like English words). - */ + /* + * "k[2]<<8" actually reads beyond the end of the string, but + * then shifts out the part it's not allowed to read. Because the + * string is aligned, the illegal read is in the same word as the + * rest of the string. Every machine with memory protection I've seen + * does it on word boundaries, so is OK with this. But VALGRIND will + * still catch it and complain. The masking trick does make the hash + * noticably faster for short strings (like English words). + */ #ifndef VALGRIND - switch ( length ) { - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += k[2] & 0xffffff00; - b += k[1]; - a += k[0]; - break; - case 10: - c += k[2] & 0xffff0000; - b += k[1]; - a += k[0]; - break; - case 9: - c += k[2] & 0xff000000; - b += k[1]; - a += k[0]; - break; - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += k[1] & 0xffffff00; - a += k[0]; - break; - case 6: - b += k[1] & 0xffff0000; - a += k[0]; - break; - case 5: - b += k[1] & 0xff000000; - a += k[0]; - break; - case 4: - a += k[0]; - break; - case 3: - a += k[0] & 0xffffff00; - break; - case 2: - a += k[0] & 0xffff0000; - break; - case 1: - a += k[0] & 0xff000000; - break; - case 0: - return c; /* zero length strings require no mixing */ - } + switch(length) + { + case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; + case 11: c+=k[2]&0xffffff00; b+=k[1]; a+=k[0]; break; + case 10: c+=k[2]&0xffff0000; b+=k[1]; a+=k[0]; break; + case 9 : c+=k[2]&0xff000000; b+=k[1]; a+=k[0]; break; + case 8 : b+=k[1]; a+=k[0]; break; + case 7 : b+=k[1]&0xffffff00; a+=k[0]; break; + case 6 : b+=k[1]&0xffff0000; a+=k[0]; break; + case 5 : b+=k[1]&0xff000000; a+=k[0]; break; + case 4 : a+=k[0]; break; + case 3 : a+=k[0]&0xffffff00; break; + case 2 : a+=k[0]&0xffff0000; break; + case 1 : a+=k[0]&0xff000000; break; + case 0 : return c; /* zero length strings require no mixing */ + } -#else /* make valgrind happy */ +#else /* make valgrind happy */ - k8 = ( const uint8_t * ) k; - switch ( length ) { /* all the case statements fall through */ - case 12: - c += k[2]; - b += k[1]; - a += k[0]; - break; - case 11: - c += ( ( uint32_t ) k8[10] ) << 8; /* fall through */ - case 10: - c += ( ( uint32_t ) k8[9] ) << 16; /* fall through */ - case 9: - c += ( ( uint32_t ) k8[8] ) << 24; /* fall through */ - case 8: - b += k[1]; - a += k[0]; - break; - case 7: - b += ( ( uint32_t ) k8[6] ) << 8; /* fall through */ - case 6: - b += ( ( uint32_t ) k8[5] ) << 16; /* fall through */ - case 5: - b += ( ( uint32_t ) k8[4] ) << 24; /* fall through */ - case 4: - a += k[0]; - break; - case 3: - a += ( ( uint32_t ) k8[2] ) << 8; /* fall through */ - case 2: - a += ( ( uint32_t ) k8[1] ) << 16; /* fall through */ - case 1: - a += ( ( uint32_t ) k8[0] ) << 24; - break; - case 0: - return c; - } + k8 = (const uint8_t *)k; + switch(length) /* all the case statements fall through */ + { + case 12: c+=k[2]; b+=k[1]; a+=k[0]; break; + case 11: c+=((uint32_t)k8[10])<<8; /* fall through */ + case 10: c+=((uint32_t)k8[9])<<16; /* fall through */ + case 9 : c+=((uint32_t)k8[8])<<24; /* fall through */ + case 8 : b+=k[1]; a+=k[0]; break; + case 7 : b+=((uint32_t)k8[6])<<8; /* fall through */ + case 6 : b+=((uint32_t)k8[5])<<16; /* fall through */ + case 5 : b+=((uint32_t)k8[4])<<24; /* fall through */ + case 4 : a+=k[0]; break; + case 3 : a+=((uint32_t)k8[2])<<8; /* fall through */ + case 2 : a+=((uint32_t)k8[1])<<16; /* fall through */ + case 1 : a+=((uint32_t)k8[0])<<24; break; + case 0 : return c; + } #endif /* !VALGRIND */ - } else { /* need to read the key one byte at a time */ - const uint8_t *k = ( const uint8_t * ) key; + } else { /* need to read the key one byte at a time */ + const uint8_t *k = (const uint8_t *)key; /*--------------- all but the last block: affect some 32 bits of (a,b,c) */ - while ( length > 12 ) { - a += ( ( uint32_t ) k[0] ) << 24; - a += ( ( uint32_t ) k[1] ) << 16; - a += ( ( uint32_t ) k[2] ) << 8; - a += ( ( uint32_t ) k[3] ); - b += ( ( uint32_t ) k[4] ) << 24; - b += ( ( uint32_t ) k[5] ) << 16; - b += ( ( uint32_t ) k[6] ) << 8; - b += ( ( uint32_t ) k[7] ); - c += ( ( uint32_t ) k[8] ) << 24; - c += ( ( uint32_t ) k[9] ) << 16; - c += ( ( uint32_t ) k[10] ) << 8; - c += ( ( uint32_t ) k[11] ); - mix( a, b, c ); - length -= 12; - k += 12; - } - - /*-------------------------------- last block: affect all 32 bits of (c) */ - switch ( length ) { /* all the case statements fall through */ - case 12: - c += k[11]; - case 11: - c += ( ( uint32_t ) k[10] ) << 8; - case 10: - c += ( ( uint32_t ) k[9] ) << 16; - case 9: - c += ( ( uint32_t ) k[8] ) << 24; - case 8: - b += k[7]; - case 7: - b += ( ( uint32_t ) k[6] ) << 8; - case 6: - b += ( ( uint32_t ) k[5] ) << 16; - case 5: - b += ( ( uint32_t ) k[4] ) << 24; - case 4: - a += k[3]; - case 3: - a += ( ( uint32_t ) k[2] ) << 8; - case 2: - a += ( ( uint32_t ) k[1] ) << 16; - case 1: - a += ( ( uint32_t ) k[0] ) << 24; - break; - case 0: - return c; - } + while (length > 12) + { + a += ((uint32_t)k[0])<<24; + a += ((uint32_t)k[1])<<16; + a += ((uint32_t)k[2])<<8; + a += ((uint32_t)k[3]); + b += ((uint32_t)k[4])<<24; + b += ((uint32_t)k[5])<<16; + b += ((uint32_t)k[6])<<8; + b += ((uint32_t)k[7]); + c += ((uint32_t)k[8])<<24; + c += ((uint32_t)k[9])<<16; + c += ((uint32_t)k[10])<<8; + c += ((uint32_t)k[11]); + mix(a,b,c); + length -= 12; + k += 12; } - final( a, b, c ); - return c; + /*-------------------------------- last block: affect all 32 bits of (c) */ + switch(length) /* all the case statements fall through */ + { + case 12: c+=k[11]; + case 11: c+=((uint32_t)k[10])<<8; + case 10: c+=((uint32_t)k[9])<<16; + case 9 : c+=((uint32_t)k[8])<<24; + case 8 : b+=k[7]; + case 7 : b+=((uint32_t)k[6])<<8; + case 6 : b+=((uint32_t)k[5])<<16; + case 5 : b+=((uint32_t)k[4])<<24; + case 4 : a+=k[3]; + case 3 : a+=((uint32_t)k[2])<<8; + case 2 : a+=((uint32_t)k[1])<<16; + case 1 : a+=((uint32_t)k[0])<<24; + break; + case 0 : return c; + } + } + + final(a,b,c); + return c; } #ifdef SELF_TEST /* used for timings */ -void driver1( ) { - uint8_t buf[256]; - uint32_t i; - uint32_t h = 0; - time_t a, z; +void driver1() +{ + uint8_t buf[256]; + uint32_t i; + uint32_t h=0; + time_t a,z; - time( &a ); - for ( i = 0; i < 256; ++i ) - buf[i] = 'x'; - for ( i = 0; i < 1; ++i ) { - h = hashlittle( &buf[0], 1, h ); - } - time( &z ); - if ( z - a > 0 ) - printf( "time %d %.8x\n", z - a, h ); + time(&a); + for (i=0; i<256; ++i) buf[i] = 'x'; + for (i=0; i<1; ++i) + { + h = hashlittle(&buf[0],1,h); + } + time(&z); + if (z-a > 0) printf("time %d %.8x\n", z-a, h); } /* check that every input bit changes every output bit half the time */ @@ -1019,263 +789,213 @@ void driver1( ) { #define HASHLEN 1 #define MAXPAIR 60 #define MAXLEN 70 -void driver2( ) { - uint8_t qa[MAXLEN + 1], qb[MAXLEN + 2], *a = &qa[0], *b = &qb[1]; - uint32_t c[HASHSTATE], d[HASHSTATE], i = 0, j = 0, k, l, m = 0, z; - uint32_t e[HASHSTATE], f[HASHSTATE], g[HASHSTATE], h[HASHSTATE]; - uint32_t x[HASHSTATE], y[HASHSTATE]; - uint32_t hlen; +void driver2() +{ + uint8_t qa[MAXLEN+1], qb[MAXLEN+2], *a = &qa[0], *b = &qb[1]; + uint32_t c[HASHSTATE], d[HASHSTATE], i=0, j=0, k, l, m=0, z; + uint32_t e[HASHSTATE],f[HASHSTATE],g[HASHSTATE],h[HASHSTATE]; + uint32_t x[HASHSTATE],y[HASHSTATE]; + uint32_t hlen; - printf( "No more than %d trials should ever be needed \n", MAXPAIR / 2 ); - for ( hlen = 0; hlen < MAXLEN; ++hlen ) { - z = 0; - for ( i = 0; i < hlen; ++i ) { -/*----------------------- for each input byte, */ - for ( j = 0; j < 8; ++j ) { -/*------------------------ for each input bit, */ - for ( m = 1; m < 8; ++m ) { -/*------------ for serveral possible initvals, */ - for ( l = 0; l < HASHSTATE; ++l ) - e[l] = f[l] = g[l] = h[l] = x[l] = y[l] = - ~( ( uint32_t ) 0 ); + printf("No more than %d trials should ever be needed \n",MAXPAIR/2); + for (hlen=0; hlen < MAXLEN; ++hlen) + { + z=0; + for (i=0; i> ( 8 - j ) ); - c[0] = hashlittle( a, hlen, m ); - b[i] ^= ( ( k + 1 ) << j ); - b[i] ^= ( ( k + 1 ) >> ( 8 - j ) ); - d[0] = hashlittle( b, hlen, m ); - /* check every bit is 1, 0, set, and not set at least once */ - for ( l = 0; l < HASHSTATE; ++l ) { - e[l] &= ( c[l] ^ d[l] ); - f[l] &= ~( c[l] ^ d[l] ); - g[l] &= c[l]; - h[l] &= ~c[l]; - x[l] &= d[l]; - y[l] &= ~d[l]; - if ( e[l] | f[l] | g[l] | h[l] | x[l] | y[l] ) - finished = 0; - } - if ( finished ) - break; - } - if ( k > z ) - z = k; - if ( k == MAXPAIR ) { - printf( "Some bit didn't change: " ); - printf( "%.8x %.8x %.8x %.8x %.8x %.8x ", - e[0], f[0], g[0], h[0], x[0], y[0] ); - printf( "i %d j %d m %d len %d\n", i, j, m, hlen ); - } - if ( z == MAXPAIR ) - goto done; - } - } - } - done: - if ( z < MAXPAIR ) { - printf( "Mix success %2d bytes %2d initvals ", i, m ); - printf( "required %d trials\n", z / 2 ); - } + /*---- check that every output bit is affected by that input bit */ + for (k=0; k>(8-j)); + c[0] = hashlittle(a, hlen, m); + b[i] ^= ((k+1)<>(8-j)); + d[0] = hashlittle(b, hlen, m); + /* check every bit is 1, 0, set, and not set at least once */ + for (l=0; lz) z=k; + if (k==MAXPAIR) + { + printf("Some bit didn't change: "); + printf("%.8x %.8x %.8x %.8x %.8x %.8x ", + e[0],f[0],g[0],h[0],x[0],y[0]); + printf("i %d j %d m %d len %d\n", i, j, m, hlen); + } + if (z==MAXPAIR) goto done; + } + } } - printf( "\n" ); + done: + if (z < MAXPAIR) + { + printf("Mix success %2d bytes %2d initvals ",i,m); + printf("required %d trials\n", z/2); + } + } + printf("\n"); } /* Check for reading beyond the end of the buffer and alignment problems */ -void driver3( ) { - uint8_t buf[MAXLEN + 20], *b; - uint32_t len; - uint8_t q[] = - "This is the time for all good men to come to the aid of their country..."; - uint32_t h; - uint8_t qq[] = - "xThis is the time for all good men to come to the aid of their country..."; - uint32_t i; - uint8_t qqq[] = - "xxThis is the time for all good men to come to the aid of their country..."; - uint32_t j; - uint8_t qqqq[] = - "xxxThis is the time for all good men to come to the aid of their country..."; - uint32_t ref, x, y; - uint8_t *p; +void driver3() +{ + uint8_t buf[MAXLEN+20], *b; + uint32_t len; + uint8_t q[] = "This is the time for all good men to come to the aid of their country..."; + uint32_t h; + uint8_t qq[] = "xThis is the time for all good men to come to the aid of their country..."; + uint32_t i; + uint8_t qqq[] = "xxThis is the time for all good men to come to the aid of their country..."; + uint32_t j; + uint8_t qqqq[] = "xxxThis is the time for all good men to come to the aid of their country..."; + uint32_t ref,x,y; + uint8_t *p; - printf - ( "Endianness. These lines should all be the same (for values filled in):\n" ); - printf - ( "%.8x %.8x %.8x\n", - hashword( ( const uint32_t * ) q, ( sizeof( q ) - 1 ) / 4, 13 ), - hashword( ( const uint32_t * ) q, ( sizeof( q ) - 5 ) / 4, 13 ), - hashword( ( const uint32_t * ) q, ( sizeof( q ) - 9 ) / 4, 13 ) ); - p = q; - printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, - sizeof( q ) - 2, - 13 ), - hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, - sizeof( q ) - 4, - 13 ), - hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, - sizeof( q ) - 6, - 13 ), - hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, - sizeof( q ) - 8, - 13 ), - hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, - sizeof( q ) - 10, - 13 ), - hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, - sizeof( q ) - - 12, 13 ) ); - p = &qq[1]; - printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, - sizeof( q ) - 2, - 13 ), - hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, - sizeof( q ) - 4, - 13 ), - hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, - sizeof( q ) - 6, - 13 ), - hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, - sizeof( q ) - 8, - 13 ), - hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, - sizeof( q ) - 10, - 13 ), - hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, - sizeof( q ) - - 12, 13 ) ); - p = &qqq[2]; - printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, - sizeof( q ) - 2, - 13 ), - hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, - sizeof( q ) - 4, - 13 ), - hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, - sizeof( q ) - 6, - 13 ), - hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, - sizeof( q ) - 8, - 13 ), - hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, - sizeof( q ) - 10, - 13 ), - hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, - sizeof( q ) - - 12, 13 ) ); - p = &qqqq[3]; - printf( "%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", - hashlittle( p, sizeof( q ) - 1, 13 ), hashlittle( p, - sizeof( q ) - 2, - 13 ), - hashlittle( p, sizeof( q ) - 3, 13 ), hashlittle( p, - sizeof( q ) - 4, - 13 ), - hashlittle( p, sizeof( q ) - 5, 13 ), hashlittle( p, - sizeof( q ) - 6, - 13 ), - hashlittle( p, sizeof( q ) - 7, 13 ), hashlittle( p, - sizeof( q ) - 8, - 13 ), - hashlittle( p, sizeof( q ) - 9, 13 ), hashlittle( p, - sizeof( q ) - 10, - 13 ), - hashlittle( p, sizeof( q ) - 11, 13 ), hashlittle( p, - sizeof( q ) - - 12, 13 ) ); - printf( "\n" ); + printf("Endianness. These lines should all be the same (for values filled in):\n"); + printf("%.8x %.8x %.8x\n", + hashword((const uint32_t *)q, (sizeof(q)-1)/4, 13), + hashword((const uint32_t *)q, (sizeof(q)-5)/4, 13), + hashword((const uint32_t *)q, (sizeof(q)-9)/4, 13)); + p = q; + printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), + hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), + hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), + hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), + hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), + hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); + p = &qq[1]; + printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), + hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), + hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), + hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), + hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), + hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); + p = &qqq[2]; + printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), + hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), + hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), + hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), + hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), + hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); + p = &qqqq[3]; + printf("%.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x %.8x\n", + hashlittle(p, sizeof(q)-1, 13), hashlittle(p, sizeof(q)-2, 13), + hashlittle(p, sizeof(q)-3, 13), hashlittle(p, sizeof(q)-4, 13), + hashlittle(p, sizeof(q)-5, 13), hashlittle(p, sizeof(q)-6, 13), + hashlittle(p, sizeof(q)-7, 13), hashlittle(p, sizeof(q)-8, 13), + hashlittle(p, sizeof(q)-9, 13), hashlittle(p, sizeof(q)-10, 13), + hashlittle(p, sizeof(q)-11, 13), hashlittle(p, sizeof(q)-12, 13)); + printf("\n"); - /* check that hashlittle2 and hashlittle produce the same results */ - i = 47; - j = 0; - hashlittle2( q, sizeof( q ), &i, &j ); - if ( hashlittle( q, sizeof( q ), 47 ) != i ) - printf( "hashlittle2 and hashlittle mismatch\n" ); + /* check that hashlittle2 and hashlittle produce the same results */ + i=47; j=0; + hashlittle2(q, sizeof(q), &i, &j); + if (hashlittle(q, sizeof(q), 47) != i) + printf("hashlittle2 and hashlittle mismatch\n"); - /* check that hashword2 and hashword produce the same results */ - len = 0xdeadbeef; - i = 47, j = 0; - hashword2( &len, 1, &i, &j ); - if ( hashword( &len, 1, 47 ) != i ) - printf( "hashword2 and hashword mismatch %x %x\n", - i, hashword( &len, 1, 47 ) ); + /* check that hashword2 and hashword produce the same results */ + len = 0xdeadbeef; + i=47, j=0; + hashword2(&len, 1, &i, &j); + if (hashword(&len, 1, 47) != i) + printf("hashword2 and hashword mismatch %x %x\n", + i, hashword(&len, 1, 47)); - /* check hashlittle doesn't read before or after the ends of the string */ - for ( h = 0, b = buf + 1; h < 8; ++h, ++b ) { - for ( i = 0; i < MAXLEN; ++i ) { - len = i; - for ( j = 0; j < i; ++j ) - *( b + j ) = 0; + /* check hashlittle doesn't read before or after the ends of the string */ + for (h=0, b=buf+1; h<8; ++h, ++b) + { + for (i=0; i + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include + +#include "consspaceobject.h" +#include "conspage.h" +#include "debug.h" +#include "dump.h" +#include "fopen.h" +#include "intern.h" +#include "io.h" +#include "lookup3.h" +#include "map.h" +#include "print.h" +#include "vectorspace.h" + +/* \todo: a lot of this will be inherited by namespaces, regularities and + * homogeneities. Exactly how I don't yet know. */ + +/** + * Get a hash value for this key. + */ +uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key) { + uint32_t result = 0; + int l = c_length(key); + + if (keywordp(key) || stringp(key) || symbolp( key)) { + if ( l > 0) { + uint32_t buffer[l]; + + if (!nilp(f)) { + fputws(L"Custom hashing functions are not yet implemented.\n", stderr); + } + for (int i = 0; i < l; i++) { + buffer[i] = (uint32_t)pointer2cell(key).payload.string.character; + } + + result = hashword( buffer, l, 0); + } + } else { + fputws(L"Hashing is thus far implemented only for keys, strings and symbols.\n", stderr); + } + + return result; +} + +/** + * get the actual map object from this `pointer`, or NULL if + * `pointer` is not a map pointer. + */ +struct map_payload *get_map_payload( struct cons_pointer pointer ) { + struct map_payload *result = NULL; + struct vector_space_object *vso = + pointer2cell( pointer ).payload.vectorp.address; + + if (vectorpointp(pointer) && mapp( vso ) ) { + result = ( struct map_payload * ) &( vso->payload ); + debug_printf( DEBUG_BIND, + L"get_map_payload: all good, returning %p\n", result ); + } else { + debug_print( L"get_map_payload: fail, returning NULL\n", DEBUG_BIND ); + } + + return result; +} + + +/** + * Make an empty immutable map, and return it. + * + * @param hash_function a pointer to a function of one argument, which + * returns an integer; or (more usually) `nil`. + * @return the new map, or NULL if memory is exhausted. + */ +struct cons_pointer make_empty_map( struct cons_pointer hash_function ) { + debug_print( L"Entering make_empty_map\n", DEBUG_BIND ); + struct cons_pointer result = + make_vso( MAPTAG, sizeof( struct map_payload ) ); + + if ( !nilp( result ) ) { + struct map_payload *payload = get_map_payload( result ); + + payload->hash_function = functionp( hash_function) ? hash_function : NIL; + inc_ref(hash_function); + + for ( int i = 0; i < BUCKETSINMAP; i++) { + payload->buckets[i] = NIL; + } + } + + debug_print( L"Leaving make_empty_map\n", DEBUG_BIND ); + return result; +} + + +struct cons_pointer make_duplicate_map( struct cons_pointer parent) { + struct cons_pointer result = NIL; + struct map_payload * parent_payload = get_map_payload(parent); + + if (parent_payload != NULL) { + result = + make_vso( MAPTAG, sizeof( struct map_payload ) ); + + if ( !nilp( result ) ) { + struct map_payload *payload = get_map_payload( result ); + + payload->hash_function = parent_payload->hash_function; + inc_ref(payload->hash_function); + + for ( int i = 0; i < BUCKETSINMAP; i++) { + payload->buckets[i] = parent_payload->buckets[i]; + inc_ref(payload->buckets[i]); + } + } + } + + return result; +} + + +struct cons_pointer bind_in_map( struct cons_pointer parent, + struct cons_pointer key, + struct cons_pointer value) { + struct cons_pointer result = make_duplicate_map(parent); + + if ( !nilp( result)) { + struct map_payload * payload = get_map_payload( result ); + int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP; + + payload->buckets[bucket] = make_cons( + make_cons(key, value), payload->buckets[bucket]); + + inc_ref(payload->buckets[bucket]); + } + + return result; +} + + +struct cons_pointer keys( struct cons_pointer store) { + debug_print( L"Entering keys\n", DEBUG_BIND ); + struct cons_pointer result = NIL; + + struct cons_space_object cell = pointer2cell( store ); + + switch (pointer2cell( store ).tag.value) { + case CONSTV: + for (struct cons_pointer c = store; !nilp(c); c = c_cdr(c)) { + result = make_cons( c_car( c_car( c)), result); + } + break; + case VECTORPOINTTV: { + struct vector_space_object *vso = + pointer2cell( store ).payload.vectorp.address; + + if ( mapp( vso ) ) { + struct map_payload * payload = get_map_payload( store ); + + for (int bucket = 0; bucket < BUCKETSINMAP; bucket++) { + for (struct cons_pointer c = payload->buckets[bucket]; + !nilp(c); c = c_cdr(c)) { + debug_print( L"keys: c is ", DEBUG_BIND); + debug_print_object( c, DEBUG_BIND); + + result = make_cons( c_car( c_car( c)), result); + debug_print( L"; result is ", DEBUG_BIND); + debug_print_object( result, DEBUG_BIND); + debug_println( DEBUG_BIND); + } + } + } + } + break; + } + debug_print( L"keys returning ", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND ); + debug_println( DEBUG_BIND); + + return result; +} + +/** + * Return a new map which represents the merger of `to_merge` into + * `parent`. `parent` must be a map, but `to_merge` may be a map or + * an assoc list. + * + * @param parent a map; + * @param to_merge an association from which key/value pairs will be merged. + * @result a new map, containing all key/value pairs from `to_merge` + * together with those key/value pairs from `parent` whose keys did not + * collide. + */ +struct cons_pointer merge_into_map( struct cons_pointer parent, + struct cons_pointer to_merge) { + debug_print( L"Entering merge_into_map\n", DEBUG_BIND ); + struct cons_pointer result = make_duplicate_map(parent); + + if (!nilp(result)) { + struct map_payload *payload = get_map_payload( result ); + for (struct cons_pointer c = keys(to_merge); + !nilp(c); c = c_cdr(c)) { + struct cons_pointer key = c_car( c); + int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP; + + payload->buckets[bucket] = make_cons( + make_cons( key, c_assoc( key, to_merge)), + payload->buckets[bucket]); + } + } + + debug_print( L"Leaving merge_into_map\n", DEBUG_BIND ); + + return result; +} + + +struct cons_pointer assoc_in_map( struct cons_pointer key, + struct cons_pointer map) { + debug_print( L"Entering assoc_in_map\n", DEBUG_BIND ); + struct cons_pointer result = NIL; + struct map_payload *payload = get_map_payload( map ); + + if (payload != NULL) { + int bucket = get_hash_32(payload->hash_function, key) % BUCKETSINMAP; + result = c_assoc(key, payload->buckets[bucket]); + } + + debug_print( L"assoc_in_map returning ", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND); + debug_println( DEBUG_BIND); + + return result; +} + + +/** + * Function: create a map initialised with key/value pairs from my + * first argument. + * + * * (make-map) + * * (make-map store) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which it is to be intepreted. + * @return a new containing all the key/value pairs from store. + */ +struct cons_pointer +lisp_make_map( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return merge_into_map( make_empty_map( NIL), frame->arg[0]); +} + +/** + * Dump a map to this stream for debugging + * @param output the stream + * @param map_pointer the pointer to the frame + */ +void dump_map( URL_FILE * output, struct cons_pointer map_pointer ) { + struct vector_space_object *vso = + pointer2cell( map_pointer ).payload.vectorp.address; + + if (vectorpointp(map_pointer) && mapp( vso ) ) { + struct map_payload *payload = get_map_payload( map_pointer ); + + if ( payload != NULL ) { + url_fputws( L"Immutable map; hash function: ", output ); + + if (nilp(payload->hash_function)) { + url_fputws( L"default", output); + } else { + dump_object( output, payload->hash_function); + } + + for (int i = 0; i < BUCKETSINMAP; i++) { + url_fwprintf(output, L"\n\tBucket %d: ", i); + print( output, payload->buckets[i]); + } + } + } +} + diff --git a/src/memory/map.h b/src/memory/map.h new file mode 100644 index 0000000..c9b5cfc --- /dev/null +++ b/src/memory/map.h @@ -0,0 +1,96 @@ +/* + * map.h + * + * An immutable hashmap in vector space. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_map_h +#define __psse_map_h + +#include "consspaceobject.h" +#include "conspage.h" + +/** + * macros for the tag of a mutable map. + */ +#define MAPTAG "IMAP" +#define MAPTV 1346456905 + +/** + * Number of buckets in a single tier map. + */ +#define BUCKETSINMAP 256 + +/** + * Maximum number of entries in an association-list bucket. + */ +#define MAXENTRIESINASSOC 16 + +/** + * true if this vector_space_object is a map, else false. + */ +#define mapp( vso) (((struct vector_space_object *)vso)->header.tag.value == MAPTV) + +/** + * The vector-space payload of a map object. Essentially a vector of + * `BUCKETSINMAP` + 1 `cons_pointer`s, but the first one is considered + * special. + */ +struct map_payload { + /** + * There is a default hash function, which is used if `hash_function` is + * `nil` (which it normally should be); and keywords will probably carry + * their own hash values. But it will be possible to override the hash + * function by putting a function of one argument returning an integer + * here. */ + struct cons_pointer hash_function; + + /** + * Obviously the number of buckets in a map is a trade off, and this may need + * tuning - or it may even be necessary to have different sized base maps. The + * idea here is that the value of a bucket is + * + * 1. `nil`; or + * 2. an association list; or + * 3. a map. + * + * All buckets are initially `nil`. Adding a value to a `nil` bucket returns + * a map with a new bucket in the form of an assoc list. Subsequent additions + * cons new key/value pairs onto the assoc list, until there are + * `MAXENTRIESINASSOC` pairs, at which point if a further value is added to + * the same bucket the bucket returned will be in the form of a second level + * map. My plan is that buckets the first level map will be indexed on the + * first sixteen bits of the hash value, those in the second on the second + * sixteen, and, potentially, so on. + */ + struct cons_pointer buckets[BUCKETSINMAP]; +}; + +uint32_t get_hash_32(struct cons_pointer f, struct cons_pointer key); + +struct map_payload *get_map_payload( struct cons_pointer pointer ); + +struct cons_pointer make_empty_map( struct cons_pointer hash_function ); + +struct cons_pointer bind_in_map( struct cons_pointer parent, + struct cons_pointer key, + struct cons_pointer value); + +struct cons_pointer keys( struct cons_pointer store); + +struct cons_pointer merge_into_map( struct cons_pointer parent, + struct cons_pointer to_merge); + +struct cons_pointer assoc_in_map( struct cons_pointer key, + struct cons_pointer map); + +struct cons_pointer lisp_make_map( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +void dump_map( URL_FILE * output, struct cons_pointer map_pointer ); + +#endif diff --git a/src/memory/stack.c b/src/memory/stack.c index 4b70ed1..3f4a271 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -17,14 +17,14 @@ #include -#include "memory/consspaceobject.h" -#include "memory/conspage.h" +#include "consspaceobject.h" +#include "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 "dump.h" +#include "lispops.h" +#include "print.h" +#include "stack.h" +#include "vectorspace.h" /** * set a register in a stack frame. Alwaye use this to do so, @@ -75,7 +75,7 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { 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 ) ); + make_vso( STACKFRAMETAG, sizeof( struct stack_frame ) ); debug_dump_object( result, DEBUG_ALLOC ); @@ -267,7 +267,7 @@ void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) { void dump_stack_trace( URL_FILE * output, struct cons_pointer pointer ) { if ( exceptionp( pointer ) ) { - print( output, pointer2cell( pointer ).payload.exception.payload ); + print( output, pointer2cell( pointer ).payload.exception.message ); url_fputws( L"\n", output ); dump_stack_trace( output, pointer2cell( pointer ).payload.exception.frame ); diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index 4bbeb51..480effb 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -19,12 +19,10 @@ #include #include -#include "memory/conspage.h" -#include "memory/consspaceobject.h" +#include "conspage.h" +#include "consspaceobject.h" #include "debug.h" -#include "memory/hashmap.h" -#include "memory/stack.h" -#include "memory/vectorspace.h" +#include "vectorspace.h" /** @@ -33,15 +31,15 @@ * * @address the address of the vector_space_object to point to. * @tag the vector-space tag of the particular type of vector-space object, - * NOT `VECTORPOINTTV`. + * NOT `VECTORPOINTTAG`. * * @return a cons_pointer to the object, or NIL if the object could not be * allocated due to memory exhaustion. */ struct cons_pointer make_vec_pointer( struct vector_space_object *address, - uint32_t tag ) { + char *tag ) { debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC ); - struct cons_pointer pointer = allocate_cell( VECTORPOINTTV ); + struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); struct cons_space_object *cell = &pointer2cell( pointer ); debug_printf( DEBUG_ALLOC, @@ -49,7 +47,7 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address, address ); cell->payload.vectorp.address = address; - cell->payload.vectorp.tag.value = tag; + strncpy( &cell->payload.vectorp.tag.bytes[0], tag, TAGLENGTH ); debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n", @@ -71,7 +69,7 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address, * @return a cons_pointer to the object, or NIL if the object could not be * allocated due to memory exhaustion. */ -struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) { +struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { debug_print( L"Entered make_vso\n", DEBUG_ALLOC ); struct cons_pointer result = NIL; int64_t total_size = sizeof( struct vector_space_header ) + payload_size; @@ -85,9 +83,9 @@ struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) { if ( vso != NULL ) { memset( vso, 0, padded ); debug_printf( DEBUG_ALLOC, - L"make_vso: about to write tag '%4.4s' into vso at %p\n", + L"make_vso: about to write tag '%s' into vso at %p\n", tag, vso ); - vso->header.tag.value = tag; + strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH ); result = make_vec_pointer( vso, tag ); debug_dump_object( result, DEBUG_ALLOC ); vso->header.vecp = result; @@ -114,38 +112,3 @@ struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ) { return result; } - -/** for vector space pointers, free the actual vector-space - * object. Dangerous! */ - -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 at 0x%lx\n", - cell.payload.vectorp.address ); - struct vector_space_object *vso = cell.payload.vectorp.address; - - switch ( vso->header.tag.value ) { - case HASHTV: - free_hashmap( pointer ); - break; - case STACKFRAMETV: - free_stack_frame( get_stack_frame( pointer ) ); - break; - } - -// free( (void *)cell.payload.vectorp.address ); - debug_printf( DEBUG_ALLOC, L"Freed vector-space object at 0x%lx\n", - cell.payload.vectorp.address ); -} - -// bool check_vso_tag( struct cons_pointer pointer, char * tag) { -// bool result = false; - -// if (check_tag(pointer, VECTORPOINTTAG)) { -// struct vector_space_object * vso = pointer_to_vso(pointer); -// result = strncmp( vso->header.tag.bytes[0], tag, TAGLENGTH); -// } - -// return result; -// } diff --git a/src/memory/vectorspace.h b/src/memory/vectorspace.h index 3265225..22b0d88 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -18,7 +18,6 @@ #include #include "consspaceobject.h" -#include "hashmap.h" #ifndef __vectorspace_h #define __vectorspace_h @@ -27,27 +26,19 @@ * part of the implementation structure of a namespace. */ #define HASHTAG "HASH" -#define HASHTV 1213415752 - -#define hashmapp(conspoint)((check_tag(conspoint,HASHTV))) +#define HASHTV 0 /* * a namespace (i.e. a binding of names to values, implemented as a hashmap) - * TODO: but note that a namespace is now essentially a hashmap with a write ACL - * whose name is interned. */ #define NAMESPACETAG "NMSP" -#define NAMESPACETV 1347636558 - -#define namespacep(conspoint)(check_tag(conspoint,NAMESPACETV)) +#define NAMESPACETV 0 /* * a vector of cons pointers. */ #define VECTORTAG "VECT" -#define VECTORTV 1413694806 - -#define vectorp(conspoint)(check_tag(conspoint,VECTORTV)) +#define VECTORTV 0 /** * given a pointer to a vector space object, return the object. @@ -59,9 +50,7 @@ */ #define vso_get_vecp(vso)((((vector_space_object)vso)->header.vecp)) -struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ); - -void free_vso( struct cons_pointer pointer ); +struct cons_pointer make_vso( char *tag, uint64_t payload_size ); /** * the header which forms the start of every vector space object. @@ -80,25 +69,6 @@ struct vector_space_header { uint64_t size; }; -/** - * The payload of a hashmap. The number of buckets is assigned at run-time, - * and is stored in n_buckets. Each bucket is something ASSOC can consume: - * i.e. either an assoc list or a further hashmap. - */ -struct hashmap_payload { - struct cons_pointer hash_fn; /* function for hashing values in this hashmap, or `NIL` to use - the default hashing function */ - struct cons_pointer write_acl; /* it seems to me that it is likely that the - * principal difference between a hashmap and a - * namespace is that a hashmap has a write ACL - * of `NIL`, meaning not writeable by anyone */ - uint32_t n_buckets; /* number of hash buckets */ - uint32_t unused; /* for word alignment and possible later expansion */ - struct cons_pointer buckets[]; /* actual hash buckets, which should be `NIL` - * or assoc lists or (possibly) further hashmaps. */ -}; - - /** a vector_space_object is just a vector_space_header followed by a * lump of bytes; what we deem to be in there is a function of the tag, * and at this stage we don't have a good picture of what these may be. @@ -111,11 +81,7 @@ struct vector_space_object { struct vector_space_header header; /** we'll malloc `size` bytes for payload, `payload` is just the first of these. * \todo this is almost certainly not idiomatic C. */ - union { - /** the payload considered as bytes */ - char bytes; - struct hashmap_payload hashmap; - } payload; + char payload; }; #endif diff --git a/src/ops/equal.c b/src/ops/equal.c index 39d80af..c4d7f54 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -10,11 +10,9 @@ #include #include -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "arith/integer.h" -#include "arith/peano.h" -#include "arith/ratio.h" +#include "conspage.h" +#include "consspaceobject.h" +#include "peano.h" /** * Shallow, and thus cheap, equality: true if these two objects are @@ -36,6 +34,7 @@ bool same_type( struct cons_pointer a, struct cons_pointer b ) { struct cons_space_object *cell_b = &pointer2cell( b ); return cell_a->tag.value == cell_b->tag.value; + } /** @@ -63,9 +62,6 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { case CONSTV: case LAMBDATV: case NLAMBDATV: - /* 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) */ result = equal( cell_a->payload.cons.car, cell_b->payload.cons.car ) && equal( cell_a->payload.cons.cdr, @@ -74,23 +70,19 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { case KEYTV: case STRINGTV: case SYMBOLTV: - /* slightly complex because a string may or may not have a '\0' + /* + * slightly complex because a string may or may not have a '\0' * cell at the end, but I'll ignore that for now. I think in * practice only the empty string will. */ - /* 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) */ result = - cell_a->payload.string.hash == cell_b->payload.string.hash - && cell_a->payload.string.character == + 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 ) ) ); + && ( 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 INTEGERTV: result = @@ -99,16 +91,13 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { 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 ); + 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 @@ -120,21 +109,15 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { result = false; break; } - } else if ( numberp( a ) && numberp( 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; 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. - */ + /* + * there's only supposed ever to be one T and one NIL cell, so each + * 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. + */ + } return result; } diff --git a/src/ops/intern.c b/src/ops/intern.c index cd80612..cf86e6b 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -19,13 +19,13 @@ #include -#include "memory/conspage.h" -#include "memory/consspaceobject.h" +#include "conspage.h" +#include "consspaceobject.h" #include "debug.h" -#include "ops/equal.h" -#include "memory/hashmap.h" -#include "ops/lispops.h" -// #include "print.h" +#include "equal.h" +#include "lispops.h" +#include "map.h" +#include "print.h" /** * The global object list/or, to put it differently, the root namespace. @@ -89,58 +89,42 @@ internedp( struct cons_pointer key, struct cons_pointer store ) { * of that key from the store; otherwise return NIL. */ struct cons_pointer c_assoc( struct cons_pointer key, - struct cons_pointer store ) { + struct cons_pointer store ) { struct cons_pointer result = NIL; - debug_print( L"c_assoc; key is `", DEBUG_BIND ); - debug_print_object( key, DEBUG_BIND ); - debug_print( L"`\n", DEBUG_BIND ); + debug_print( L"c_assoc; key is `", DEBUG_BIND); + debug_print_object( key, DEBUG_BIND); + debug_print( L"`\n", DEBUG_BIND); - if ( consp( store ) ) { + 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 ); + consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { + struct cons_space_object entry = + pointer2cell( pointer2cell( next ).payload.cons.car ); - 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 ); - } + if ( equal( key, entry.payload.cons.car ) ) { + result = entry.payload.cons.cdr; + break; } } - } 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 ); + } else if (vectorpointp( store)) { + result = assoc_in_map( key, store); } - debug_print( L"c_assoc returning ", DEBUG_BIND ); - debug_print_object( result, DEBUG_BIND ); - debug_println( DEBUG_BIND ); + debug_print( L"c_assoc returning ", DEBUG_BIND); + debug_print_object( result, DEBUG_BIND); + debug_println( DEBUG_BIND); return result; } - /** - * 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 ) { +/** + * 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; debug_print( L"set: binding `", DEBUG_BIND ); @@ -148,18 +132,18 @@ struct cons_pointer set( struct cons_pointer key, struct cons_pointer value, 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_dump_object( store, DEBUG_BIND); debug_println( DEBUG_BIND ); - if ( nilp( store ) || consp( store ) ) { + if (nilp( store) || consp(store)) { result = make_cons( make_cons( key, value ), store ); - } else if ( hashmapp( store ) ) { - result = hashmap_put( store, key, value ); + } else if (vectorpointp( store)) { + result = bind_in_map( store, key, value); } - debug_print( L"set returning ", DEBUG_BIND ); - debug_print_object( result, DEBUG_BIND ); - debug_println( DEBUG_BIND ); + debug_print( L"set returning ", DEBUG_BIND); + debug_print_object( result, DEBUG_BIND); + debug_println( DEBUG_BIND); return result; } @@ -181,11 +165,8 @@ deep_bind( struct cons_pointer key, struct cons_pointer value ) { debug_println( DEBUG_BIND ); oblist = set( key, value, oblist ); - - if ( consp( oblist ) ) { - inc_ref( oblist ); - dec_ref( old ); - } + inc_ref( oblist ); + dec_ref( old ); debug_print( L"deep_bind returning ", DEBUG_BIND ); debug_print_object( oblist, DEBUG_BIND ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index f9fb95a..4e2ddbf 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -24,24 +24,27 @@ #include #include -#include "memory/consspaceobject.h" -#include "memory/conspage.h" +#include "consspaceobject.h" +#include "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" -#include "io/print.h" -#include "io/read.h" -#include "memory/stack.h" -#include "memory/vectorspace.h" +#include "dump.h" +#include "equal.h" +#include "integer.h" +#include "intern.h" +#include "io.h" +#include "lispops.h" +#include "map.h" +#include "print.h" +#include "read.h" +#include "stack.h" +#include "vectorspace.h" /* * also to create in this section: * struct cons_pointer lisp_let( struct cons_pointer args, struct cons_pointer env, * struct stack_frame* frame); + * struct cons_pointer lisp_mapcar( struct cons_pointer args, struct cons_pointer env, + * struct stack_frame* frame); * * and others I haven't thought of yet. */ @@ -60,54 +63,25 @@ struct cons_pointer eval_form( struct stack_frame *parent, struct cons_pointer form, struct cons_pointer env ) { debug_print( L"eval_form: ", DEBUG_EVAL ); - debug_print_object( form, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); + debug_dump_object( form, DEBUG_EVAL ); - struct cons_pointer result = form; - switch ( pointer2cell( form ).tag.value ) { - /* 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... - case NILTV: - case RATIOTV: - case REALTV: - case READTV: - 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 ); + struct cons_pointer result = NIL; + struct cons_pointer next_pointer = make_empty_frame( parent_pointer ); + inc_ref( next_pointer ); - struct stack_frame *next = get_stack_frame( next_pointer ); - set_reg( next, 0, form ); - next->args = 1; + struct stack_frame *next = get_stack_frame( next_pointer ); + set_reg( next, 0, form ); + next->args = 1; - result = lisp_eval( next, next_pointer, env ); + 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; + 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 ); } - debug_print( L"eval_form returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - return result; } @@ -133,39 +107,9 @@ struct cons_pointer eval_forms( struct stack_frame *frame, list = c_cdr( list ); } - return c_reverse( result ); -} - -/** - * OK, the idea here (and I know this is less than perfect) is that the basic `try` - * special form in PSSE takes two arguments, the first, `body`, being a list of forms, - * and the second, `catch`, being a catch handler (which is also a list of forms). - * Forms from `body` are evaluated in turn until one returns an exception object, - * or until the list is exhausted. If the list was exhausted, then the value of - * evaluating the last form in `body` is returned. If an exception was encountered, - * then each of the forms in `catch` is evaluated and the value of the last of - * those is returned. - * - * This is experimental. It almost certainly WILL change. - */ -struct cons_pointer lisp_try( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = - c_progn( frame, frame_pointer, frame->arg[0], env ); - - if ( exceptionp( result ) ) { - // TODO: need to put the exception into the environment! - result = c_progn( frame, frame_pointer, frame->arg[1], - make_cons( make_cons - ( c_string_to_lisp_symbol - ( L"*exception*" ), result ), env ) ); - } - return result; } - /** * Return the object list (root namespace). * @@ -307,10 +251,6 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, dec_ref( result ); result = eval_form( frame, frame_pointer, sexpr, new_env ); - - if ( exceptionp( result ) ) { - break; - } } dec_ref( new_env ); @@ -331,8 +271,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, * @return the result of evaluating the function with its arguments. */ struct cons_pointer -c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { + c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { debug_print( L"Entering c_apply\n", DEBUG_EVAL ); struct cons_pointer result = NIL; @@ -347,123 +287,122 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, switch ( fn_cell.tag.value ) { case EXCEPTIONTV: - /* just pass exceptions straight back */ - result = fn_pointer; - break; + /* just pass exceptions straight back */ + result = fn_pointer; + break; case FUNCTIONTV: - { - struct cons_pointer exep = NIL; - struct cons_pointer next_pointer = - make_stack_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); + { + struct cons_pointer exep = NIL; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); - result = - ( *fn_cell.payload.function.executable ) ( next, - next_pointer, - env ); - dec_ref( next_pointer ); - } + result = + ( *fn_cell.payload.function.executable ) ( next, + next_pointer, + env ); + dec_ref( next_pointer ); } - break; + } + break; case KEYTV: - result = c_assoc( fn_pointer, - eval_form( frame, - frame_pointer, - c_car( c_cdr( frame->arg[0] ) ), - env ) ); - break; + result = c_assoc( fn_pointer, + eval_form(frame, + frame_pointer, + c_car( c_cdr( frame->arg[0])), + env)); + break; case LAMBDATV: - { - struct cons_pointer exep = NIL; - struct cons_pointer next_pointer = - make_stack_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - result = - eval_lambda( fn_cell, next, next_pointer, env ); - if ( !exceptionp( result ) ) { - dec_ref( next_pointer ); - } + { + struct cons_pointer exep = NIL; + struct cons_pointer next_pointer = + make_stack_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + if ( !exceptionp( result ) ) { + dec_ref( next_pointer ); } } - break; + } + break; 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; - } + switch ( pointer_to_vso(fn_pointer)->header.tag.value) { + case MAPTV: + /* \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 ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - struct stack_frame *next = - get_stack_frame( next_pointer ); - result = - eval_lambda( fn_cell, next, next_pointer, env ); - dec_ref( next_pointer ); - } + { + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + struct stack_frame *next = + get_stack_frame( next_pointer ); + result = + eval_lambda( fn_cell, next, next_pointer, env ); + dec_ref( next_pointer ); } - break; + } + break; case SPECIALTV: - { - struct cons_pointer next_pointer = - make_special_frame( frame_pointer, args, env ); - inc_ref( next_pointer ); - if ( exceptionp( next_pointer ) ) { - result = next_pointer; - } else { - result = - ( *fn_cell.payload.special. - executable ) ( get_stack_frame( next_pointer ), - next_pointer, env ); - debug_print( L"Special form returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - dec_ref( next_pointer ); - } + { + struct cons_pointer next_pointer = + make_special_frame( frame_pointer, args, env ); + inc_ref( next_pointer ); + if ( exceptionp( next_pointer ) ) { + result = next_pointer; + } else { + result = + ( *fn_cell.payload.special. + executable ) ( get_stack_frame( next_pointer ), + next_pointer, env ); + debug_print( L"Special form returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + dec_ref( next_pointer ); } - break; + } + break; default: - { - int bs = sizeof( wchar_t ) * 1024; - wchar_t *buffer = malloc( bs ); - memset( buffer, '\0', bs ); - swprintf( buffer, bs, - L"Unexpected cell with tag %d (%4.4s) in function position", - fn_cell.tag.value, &fn_cell.tag.bytes[0] ); - struct cons_pointer message = - c_string_to_lisp_string( buffer ); - free( buffer ); - result = throw_exception( message, frame_pointer ); - } + { + int bs = sizeof( wchar_t ) * 1024; + wchar_t *buffer = malloc( bs ); + memset( buffer, '\0', bs ); + swprintf( buffer, bs, + L"Unexpected cell with tag %d (%4.4s) in function position", + fn_cell.tag.value, &fn_cell.tag.bytes[0] ); + struct cons_pointer message = + c_string_to_lisp_string( buffer ); + free( buffer ); + result = throw_exception( message, frame_pointer ); + } } } @@ -505,7 +444,7 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, switch ( cell.tag.value ) { case CONSTV: - result = c_apply( frame, frame_pointer, env ); + result = c_apply( frame, frame_pointer, env ); break; case SYMBOLTV: @@ -617,11 +556,11 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, result = frame->arg[1]; } else { result = - 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 ) ), - frame_pointer ); + make_exception( make_cons + ( c_string_to_lisp_string + ( L"The first argument to `set` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), + frame_pointer ); } return result; @@ -656,11 +595,11 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, result = val; } else { result = - 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 ) ), - frame_pointer ); + make_exception( make_cons + ( c_string_to_lisp_string + ( L"The first argument to `set!` is not a symbol: " ), + make_cons( frame->arg[0], NIL ) ), + frame_pointer ); } return result; @@ -807,10 +746,9 @@ lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, * @param env my environment (ignored). * @return the length of `any`, if it is a sequence, or zero otherwise. */ -struct cons_pointer lisp_length( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return make_integer( c_length( frame->arg[0] ), NIL ); +struct cons_pointer lisp_length( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_integer( c_length( frame->arg[0]), NIL); } /** @@ -829,26 +767,6 @@ lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, return c_assoc( frame->arg[0], frame->arg[1] ); } -struct cons_pointer c_keys( struct cons_pointer store ) { - struct cons_pointer result = NIL; - - if ( hashmapp( store ) ) { - result = hashmap_keys( store ); - } else if ( consp( store ) ) { - for ( struct cons_pointer c = store; !nilp( c ); c = c_cdr( c ) ) { - result = make_cons( c_car( c ), result ); - } - } - - return result; -} - -struct cons_pointer lisp_keys( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return c_keys( frame->arg[0] ); -} - /** * Function; are these two objects the same object? Shallow, cheap equality. * @@ -881,6 +799,26 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, return equal( frame->arg[0], frame->arg[1] ) ? TRUE : NIL; } + +/** + * Resutn the current default input, or of `inputp` is false, output stream from + * this `env`ironment. + */ +struct cons_pointer get_default_stream( bool inputp, struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_pointer stream_name = + c_string_to_lisp_symbol( inputp ? L"*in*" : L"*out*" ); + + inc_ref( stream_name ); + + result = c_assoc( stream_name, env ); + + dec_ref( stream_name ); + + return result; +} + + /** * Function; read one complete lisp form and return it. If read-stream is specified and * is a read stream, then read from that stream, else the stream which is the value of @@ -914,7 +852,7 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, input = file_to_url_file( stdin ); } - struct cons_pointer result = read( frame, frame_pointer, env, input ); + struct cons_pointer result = read( frame, frame_pointer, input ); debug_print( L"lisp_read returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); @@ -930,30 +868,26 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * reverse a sequence (if it is a sequence); else return it unchanged. + * reverse a sequence. */ struct cons_pointer c_reverse( struct cons_pointer arg ) { struct cons_pointer result = NIL; - if ( sequencep( arg ) ) { - for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) { - struct cons_space_object o = pointer2cell( p ); - switch ( o.tag.value ) { - case CONSTV: - result = make_cons( o.payload.cons.car, result ); - break; - case STRINGTV: - result = make_string( o.payload.string.character, result ); - break; - case SYMBOLTV: - result = - make_symbol_or_key( o.payload.string.character, result, - SYMBOLTV ); - break; - } + for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) { + struct cons_space_object o = pointer2cell( p ); + switch ( o.tag.value ) { + case CONSTV: + result = make_cons( o.payload.cons.car, result ); + break; + case STRINGTV: + result = make_string( o.payload.string.character, result ); + break; + case SYMBOLTV: + result = + make_symbol_or_key( o.payload.string.character, result, + SYMBOLTAG ); + break; } - } else { - result = arg; } return result; @@ -976,44 +910,6 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, return c_reverse( frame->arg[0] ); } -/** - * Function: dump/inspect 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. - * - * * (inspect expr) - * * (inspect 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_inspect( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - debug_print( L"Entering lisp_inspect\n", DEBUG_IO ); - struct cons_pointer result = NIL; - struct cons_pointer out_stream = writep( frame->arg[1] ) - ? frame->arg[1] - : get_default_stream( false, env ); - URL_FILE *output; - - if ( writep( out_stream ) ) { - debug_print( L"lisp_inspect: setting output stream\n", DEBUG_IO ); - debug_dump_object( out_stream, DEBUG_IO ); - output = pointer2cell( out_stream ).payload.stream.stream; - } else { - output = file_to_url_file( stderr ); - } - - dump_object( output, frame->arg[0] ); - - debug_print( L"Leaving lisp_inspect", DEBUG_IO ); - - return result; -} /** * Function; print one complete lisp expression and return NIL. If write-stream is specified and @@ -1025,8 +921,8 @@ struct cons_pointer lisp_inspect( struct stack_frame *frame, * * @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. + * @param env my environment (ignored). + * @return the value of `expr`. */ struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -1095,7 +991,7 @@ c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, result = eval_form( frame, frame_pointer, c_car( expressions ), env ); dec_ref( r ); - expressions = exceptionp( result ) ? NIL : c_cdr( expressions ); + expressions = c_cdr( expressions ); } return result; @@ -1236,8 +1132,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( message, - frame->previous ); + return exceptionp( message ) ? message : make_exception( message, + frame->previous ); } /** @@ -1256,36 +1152,23 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer expr = NIL; - - debug_printf(DEBUG_REPL, L"Entering new inner REPL\n"); + + /* \todo bind *prompt*, *input*, *output* in the environment to the values + * of arguments 0, 1, and 2 respectively, but in each case only if the + * argument is not nil */ struct cons_pointer input = get_default_stream( true, env ); struct cons_pointer output = get_default_stream( false, env ); + URL_FILE *os = pointer2cell( output ).payload.stream.stream; struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); struct cons_pointer old_oblist = oblist; struct cons_pointer new_env = env; - inc_ref( env ); - 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); - input = frame->arg[1]; - } - 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 ); - 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 @@ -1300,8 +1183,6 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, * are not visible. So copy changes made in the oblist into the enviroment. * \todo the whole process of resolving symbol values needs to be revisited * when we get onto namespaces. */ - /* OK, there's something even more subtle here if the root namespace is a map. - * H'mmmm... */ if ( !eq( oblist, old_oblist ) ) { struct cons_pointer cursor = oblist; @@ -1350,8 +1231,6 @@ struct cons_pointer lisp_repl( struct stack_frame *frame, dec_ref( prompt_name ); dec_ref( env ); - debug_printf(DEBUG_REPL, L"Leaving inner repl\n"); - return expr; } @@ -1397,202 +1276,44 @@ struct cons_pointer lisp_source( struct stack_frame *frame, return result; } -/** - * A version of append which can conveniently be called from C. - */ -struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ) { - switch ( pointer2cell( l1 ).tag.value ) { - case CONSTV: - if ( pointer2cell( l1 ).tag.value == pointer2cell( l2 ).tag.value ) { - if ( nilp( c_cdr( l1 ) ) ) { - return make_cons( c_car( l1 ), l2 ); - } else { - return make_cons( c_car( l1 ), - c_append( c_cdr( l1 ), l2 ) ); - } - } else { - throw_exception( c_string_to_lisp_string - ( L"Can't append: not same type" ), NIL ); - } - break; - case KEYTV: - case STRINGTV: - case SYMBOLTV: - 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, - pointer2cell( l1 ).tag.value ); - } else { - return - 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_string - ( L"Can't append: not same type" ), NIL ); - } - break; - default: - throw_exception( c_string_to_lisp_string - ( L"Can't append: not a sequence" ), NIL ); - break; - } -} /** - * should really be overwritten with a version in Lisp, since this is much easier to write in Lisp + * 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_append( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = fetch_arg( frame, ( frame->args - 1 ) ); +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 = frame->args - 2; a >= 0; a-- ) { - result = c_append( fetch_arg( frame, a ), result ); + 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 ); } - return result; + dump_object( output, frame->arg[0] ); + url_fputws( L"\n", output ); + + if ( writep( out_stream ) ) { + dec_ref( out_stream ); + } else { + free( output ); + } + + return frame->arg[0]; } - -struct cons_pointer lisp_mapcar( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = NIL; - debug_print( L"Mapcar: ", DEBUG_EVAL ); - debug_dump_object( frame_pointer, DEBUG_EVAL ); - int i = 0; - - for ( struct cons_pointer c = frame->arg[1]; truep( c ); c = c_cdr( c ) ) { - struct cons_pointer expr = - make_cons( frame->arg[0], make_cons( c_car( c ), NIL ) ); - inc_ref( expr ); - - debug_printf( DEBUG_EVAL, L"Mapcar %d, evaluating ", i ); - debug_print_object( expr, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - struct cons_pointer r = eval_form( frame, frame_pointer, expr, env ); - - if ( exceptionp( r ) ) { - result = r; - inc_ref( expr ); // to protect exception from the later dec_ref - break; - } else { - result = make_cons( r, result ); - } - debug_printf( DEBUG_EVAL, L"Mapcar %d, result is ", i++ ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - dec_ref( expr ); - } - - result = consp( result ) ? c_reverse( result ) : result; - - debug_print( L"Mapcar returning: ", DEBUG_EVAL ); - debug_print_object( result, DEBUG_EVAL ); - debug_println( DEBUG_EVAL ); - - return result; -} - -struct cons_pointer lisp_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer result = frame->more; - - for ( int a = nilp( result ) ? frame->args - 1 : args_in_frame - 1; - a >= 0; a-- ) { - result = make_cons( fetch_arg( frame, a ), result ); - } - - return result; -} - -/** - * Special form: evaluate a series of forms in an environment in which - * these bindings are bound. - * This is `let*` in Common Lisp parlance; `let` in Clojure parlance. - */ -struct cons_pointer lisp_let( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer bindings = env; - struct cons_pointer result = NIL; - - for ( struct cons_pointer cursor = frame->arg[0]; - truep( cursor ); cursor = c_cdr( cursor ) ) { - struct cons_pointer pair = c_car( cursor ); - struct cons_pointer symbol = c_car( pair ); - - if ( symbolp( symbol ) ) { - bindings = - make_cons( make_cons - ( symbol, - eval_form( frame, frame_pointer, c_cdr( pair ), - bindings ) ), bindings ); - - } else { - result = - throw_exception( c_string_to_lisp_string - ( L"Let: cannot bind, not a symbol" ), - frame_pointer ); - break; - } - } - - /* i.e., no exception yet */ - for ( int form = 1; !exceptionp( result ) && form < frame->args; form++ ) { - result = - eval_form( frame, frame_pointer, fetch_arg( frame, form ), - bindings ); - } - - return result; - -} - -// /** -// * Function; print the internal representation of the object indicated by `frame->arg[0]` to the -// * (optional, defaults to the value of `*out*` in the environment) stream indicated by `frame->arg[1]`. -// * -// * * (inspect expression) -// * * (inspect expression ) -// * -// * @param frame my stack frame. -// * @param frame_pointer a pointer to my stack_frame. -// * @param env the environment. -// * @return the value of the first argument - `expression`. -// */ -// struct cons_pointer lisp_inspect( struct stack_frame *frame, -// struct cons_pointer frame_pointer, -// struct cons_pointer env ) { -// debug_print( L"Entering print\n", DEBUG_IO ); -// URL_FILE *output; -// struct cons_pointer out_stream = writep( frame->arg[1] ) ? -// frame->arg[1] : get_default_stream( false, env ); - -// if ( writep( out_stream ) ) { -// debug_print( L"lisp_print: setting output stream\n", DEBUG_IO ); -// debug_dump_object( out_stream, DEBUG_IO ); -// output = pointer2cell( out_stream ).payload.stream.stream; -// inc_ref( out_stream ); -// } else { -// output = file_to_url_file( stdout ); -// } - -// dump_object( output, frame->arg[0] ); -// url_fputws( L"\n", output ); - -// if ( writep( out_stream ) ) { -// dec_ref( out_stream ); -// } else { -// free( output ); -// } - -// return frame->arg[0]; -// } diff --git a/src/ops/lispops.h b/src/ops/lispops.h index da1f27e..122635f 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -26,15 +26,9 @@ * utilities */ -struct cons_pointer c_keys( struct cons_pointer store ); struct cons_pointer c_reverse( struct cons_pointer arg ); -struct cons_pointer c_progn( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer expressions, - struct cons_pointer env ); - /** * Useful building block; evaluate this single form in the context of this * parent stack frame and this environment. @@ -58,6 +52,7 @@ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer list, struct cons_pointer env ); + /* * special forms */ @@ -68,21 +63,17 @@ struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_keys( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); -struct cons_pointer lisp_oblist( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); -struct cons_pointer lisp_set( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_set_shriek( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Construct an interpretable function. @@ -95,17 +86,17 @@ struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); struct cons_pointer lisp_length( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); + struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Construct an interpretable special form. * * @param frame the stack frame in which the expression is to be interpreted; * @param env the environment in which it is to be intepreted. */ -struct cons_pointer lisp_nlambda( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -114,9 +105,6 @@ struct cons_pointer lisp_quote( struct stack_frame *frame, /* * functions */ -struct cons_pointer lisp_assoc( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); @@ -126,9 +114,9 @@ struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer lisp_inspect( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer lisp_assoc( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); @@ -154,9 +142,10 @@ struct cons_pointer lisp_reverse( struct stack_frame *frame, * @param env My environment (ignored). * @return As a Lisp string, the tag of the object which is the argument. */ -struct cons_pointer lisp_type( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); + /** * Function; evaluate the forms which are listed in my single argument @@ -168,9 +157,9 @@ struct cons_pointer lisp_type( struct stack_frame *frame, * @return the value of the last form on the sequence which is my single * argument. */ -struct cons_pointer lisp_progn( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * Special form: conditional. Each arg is expected to be a list; if the first @@ -181,46 +170,29 @@ struct cons_pointer lisp_progn( struct stack_frame *frame, * @param env My environment (ignored). * @return the value of the last form of the first successful clause. */ -struct cons_pointer lisp_cond( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); /** * 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. + * `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 message, struct cons_pointer frame_pointer ); -struct cons_pointer lisp_exception( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer +lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_source( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer c_append( struct cons_pointer l1, struct cons_pointer l2 ); +struct cons_pointer lisp_inspect( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); -struct cons_pointer lisp_append( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_mapcar( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_let( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); - -struct cons_pointer lisp_try( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); #endif diff --git a/src/ops/loop.c b/src/ops/loop.c deleted file mode 100644 index 6ccada6..0000000 --- a/src/ops/loop.c +++ /dev/null @@ -1,50 +0,0 @@ -/* - * loop.c - * - * Iteration functions. This has *a lot* of similarity to try/catch -- - * essentially what `recur` does is throw a special purpose exception which is - * caught by `loop`. - * - * Essentially the syntax I want is - * - * (defun expt (n e) - * (loop ((n1 . n) (r . n) (e1 . e)) - * (cond ((= e 0) r) - * (t (recur n1 (* n1 r) (- e 1))))) - * - * It might in future be good to allow the body of the loop to comprise many - * expressions, like a `progn`, but for now if you want that you can just - * shove a `progn` in. Note that, given that what `recur` is essentially - * doing is throwing a special purpose exception, the `recur` expression - * doesn't actually have to be in the same function as the `loop` expression. - * - * (c) 2021 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include "consspaceobject.h" -#include "lispops.h" -#include "loop.h" - -/** - * Special form, not dissimilar to `let`. Essentially, - * - * 1. the first arg (`args`) is an assoc list; - * 2. the second arg (`body`) is an expression. - * - * Each of the vals in the assoc list is evaluated, and bound to its - * respective key in a new environment. The body is then evaled in that - * environment. If the result is an object of type LOOP, it should carry - * a list of values of the same arity as args. Each of the keys in args - * is then rebound in a new environment to the respective value from the - * LOOP object, and body is then re-evaled in that environment. - * - * If the result is not a LOOP object, it is simply returned. - */ -struct cons_pointer -lisp_loop( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ) { - struct cons_pointer keys = c_keys( frame->arg[0] ); - struct cons_pointer body = frame->arg[1]; - -} diff --git a/src/ops/loop.h b/src/ops/loop.h deleted file mode 100644 index 27714a8..0000000 --- a/src/ops/loop.h +++ /dev/null @@ -1,10 +0,0 @@ -/* - * loop.h - * - * Iteration functions. This has *a lot* of similarity to try/catch -- - * essentially what `recur` does is throw a special purpose exception which is - * caught by `loop`. - * - * (c) 2021 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ diff --git a/src/ops/meta.c b/src/ops/meta.c index f00824f..a27d2af 100644 --- a/src/ops/meta.c +++ b/src/ops/meta.c @@ -7,7 +7,7 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ -#include "memory/conspage.h" +#include "conspage.h" #include "debug.h" /** diff --git a/src/repl.c b/src/repl.c index bef08b1..0ea104d 100644 --- a/src/repl.c +++ b/src/repl.c @@ -11,11 +11,11 @@ #include #include -#include "memory/consspaceobject.h" +#include "consspaceobject.h" #include "debug.h" -#include "ops/intern.h" -#include "ops/lispops.h" -#include "memory/stack.h" +#include "intern.h" +#include "lispops.h" +#include "stack.h" /** @@ -24,16 +24,12 @@ void repl( ) { debug_print( L"Entered repl\n", DEBUG_REPL ); - struct cons_pointer env = - consp( oblist ) ? oblist : make_cons( oblist, NIL ); - - /* bottom of stack */ - struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, env ); + struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, oblist ); if ( !nilp( frame_pointer ) ) { inc_ref( frame_pointer ); - lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, env ); + lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, oblist ); dec_ref( frame_pointer ); } diff --git a/src/time/psse_time.c b/src/time/psse_time.c index 06c1b58..76f52a9 100644 --- a/src/time/psse_time.c +++ b/src/time/psse_time.c @@ -16,10 +16,10 @@ #include #include -#include "memory/conspage.h" -#include "memory/consspaceobject.h" -#include "arith/integer.h" -#include "time/psse_time.h" +#include "conspage.h" +#include "consspaceobject.h" +#include "integer.h" +#include "psse_time.h" #define _GNU_SOURCE #define seconds_per_year 31557600L @@ -28,43 +28,42 @@ * PSSE Lisp epoch is 14 Bn years, or 441,806,400,000,000,000 seconds, before * the UNIX epoch; the value in microseconds will break the C reader. */ -unsigned __int128 epoch_offset = - ( ( __int128 ) ( seconds_per_year * 1000000000L ) * - ( __int128 ) ( 14L * 1000000000L ) ); +unsigned __int128 epoch_offset = ((__int128)(seconds_per_year * 1000000000L) * + (__int128)(14L * 1000000000L)); /** * Return the UNIX time value which represents this time, if it falls within * the period representable in UNIX time, or zero otherwise. */ -long int lisp_time_to_unix_time( struct cons_pointer t ) { +long int lisp_time_to_unix_time(struct cons_pointer t) { long int result = 0; - if ( timep( t ) ) { - unsigned __int128 value = pointer2cell( t ).payload.time.value; + if (timep( t)) { + unsigned __int128 value = pointer2cell(t).payload.time.value; - if ( value > epoch_offset ) { // \todo && value < UNIX time rollover - result = ( ( value - epoch_offset ) / 1000000000 ); + if (value > epoch_offset) { // \todo && value < UNIX time rollover + result = ((value - epoch_offset) / 1000000000); } } return result; } -unsigned __int128 unix_time_to_lisp_time( time_t t ) { - unsigned __int128 result = epoch_offset + ( t * 1000000000 ); +unsigned __int128 unix_time_to_lisp_time( time_t t) { + unsigned __int128 result = epoch_offset + (t * 1000000000); return result; } -struct cons_pointer make_time( struct cons_pointer integer_or_nil ) { - struct cons_pointer pointer = allocate_cell( TIMETV ); +struct cons_pointer make_time( struct cons_pointer integer_or_nil) { + struct cons_pointer pointer = allocate_cell( TIMETAG ); struct cons_space_object *cell = &pointer2cell( pointer ); - if ( integerp( integer_or_nil ) ) { - cell->payload.time.value = - pointer2cell( integer_or_nil ).payload.integer.value; + if (integerp(integer_or_nil)) { + cell->payload.time.value = pointer2cell(integer_or_nil).payload.integer.value; + // \todo: if integer is a bignum, deal with it. } else { - cell->payload.time.value = unix_time_to_lisp_time( time( NULL ) ); + cell->payload.time.value = unix_time_to_lisp_time( time(NULL)); } return pointer; @@ -83,26 +82,25 @@ struct cons_pointer make_time( struct cons_pointer integer_or_nil ) { * is that number of microseconds after the notional big bang; else the current * time. */ -struct cons_pointer lisp_time( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ) { - return make_time( frame->arg[0] ); +struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + return make_time( frame->arg[0]); } /** * This is temporary, for bootstrapping. */ -struct cons_pointer time_to_string( struct cons_pointer pointer ) { +struct cons_pointer time_to_string( struct cons_pointer pointer) { struct cons_pointer result = NIL; - long int t = lisp_time_to_unix_time( pointer ); + long int t = lisp_time_to_unix_time(pointer); - if ( t != 0 ) { - char *bytes = ctime( &t ); - int l = strlen( bytes ) + 1; - wchar_t buffer[l]; + if ( t != 0) { + char * bytes = ctime(&t); + int l = strlen(bytes) + 1; + wchar_t buffer[ l]; - mbstowcs( buffer, bytes, l ); - result = c_string_to_lisp_string( buffer ); + mbstowcs( buffer, bytes, l); + result = c_string_to_lisp_string( buffer); } return result; diff --git a/src/time/psse_time.h b/src/time/psse_time.h index f2afdd2..af70966 100644 --- a/src/time/psse_time.h +++ b/src/time/psse_time.h @@ -13,9 +13,8 @@ #define _GNU_SOURCE #include "consspaceobject.h" -struct cons_pointer lisp_time( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); -struct cons_pointer time_to_string( struct cons_pointer pointer ); +struct cons_pointer lisp_time( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer time_to_string( struct cons_pointer pointer); #endif diff --git a/src/version.h b/src/version.h index c9e2cf6..0e08c48 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.5" +#define VERSION "0.0.5-SNAPSHOT" diff --git a/unit-tests/append.sh b/unit-tests/append.sh deleted file mode 100755 index 0f6fb30..0000000 --- a/unit-tests/append.sh +++ /dev/null @@ -1,24 +0,0 @@ -#!/bin/bash - -expected='(a b c d e f)' -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}'" - exit 1 -fi - -expected='"hellodere"' -actual=`echo '(append "hello" "dere")' | target/psse | tail -1` - -if [ "${expected}" = "${actual}" ] -then - echo "OK" -else - echo "Fail: expected '${expected}', got '${actual}'" - exit 1 -fi - diff --git a/unit-tests/integer-allocation.sh b/unit-tests/integer-allocation.sh index b25bef3..ced92f2 100755 --- a/unit-tests/integer-allocation.sh +++ b/unit-tests/integer-allocation.sh @@ -1,8 +1,8 @@ #!/bin/bash value=354 -expected="(${value} \"INTR\")" -echo "(set! x $value)(list x (type x))" | target/psse 2>&1 | grep "${expected}" > /dev/null +expected="Integer cell: value ${value}," +echo ${value} | target/psse -v5 2>&1 | grep "${expected}" > /dev/null if [ $? -eq 0 ] then diff --git a/unit-tests/lambda.sh b/unit-tests/lambda.sh index 9695e6c..b7f1707 100755 --- a/unit-tests/lambda.sh +++ b/unit-tests/lambda.sh @@ -1,6 +1,6 @@ #!/bin/bash -expected=' (1 2 3 4 5 6 7 8 9 10)' +expected='(lambda (l) l) (1 2 3 4 5 6 7 8 9 10)' output=`target/psse 2>/dev/null <