diff --git a/.gitignore b/.gitignore index bdd460c..b07b2a6 100644 --- a/.gitignore +++ b/.gitignore @@ -31,10 +31,18 @@ log* utils_src/readprintwc/out -.kdev4/ +*.dump + +*.bak + +src/io/fopen + +hi\.* .vscode/ -hi.* +core + +.kdev4/ post-scarcity.kdev4 diff --git a/Doxyfile b/Doxyfile index 955cb32..e283f9a 100644 --- a/Doxyfile +++ b/Doxyfile @@ -135,7 +135,7 @@ ABBREVIATE_BRIEF = "The $name class" \ # description. # The default value is: NO. -ALWAYS_DETAILED_SEC = NO +ALWAYS_DETAILED_SEC = YES # If the INLINE_INHERITED_MEMB tag is set to YES, doxygen will show all # inherited members of a class in the documentation of that class as if those @@ -162,7 +162,7 @@ FULL_PATH_NAMES = YES # will be relative from the directory where doxygen is started. # This tag requires that the tag FULL_PATH_NAMES is set to YES. -STRIP_FROM_PATH = +STRIP_FROM_PATH = src/ # The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the # path mentioned in the documentation of a class, which tells the reader which @@ -187,7 +187,7 @@ SHORT_NAMES = NO # description.) # The default value is: NO. -JAVADOC_AUTOBRIEF = NO +JAVADOC_AUTOBRIEF = YES # If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first # line (until the first dot) of a Qt-style comment as the brief description. If @@ -397,7 +397,7 @@ INLINE_GROUPED_CLASSES = NO # Man pages) or section (for LaTeX and RTF). # The default value is: NO. -INLINE_SIMPLE_STRUCTS = NO +INLINE_SIMPLE_STRUCTS = YES # When TYPEDEF_HIDES_STRUCT tag is enabled, a typedef of a struct, union, or # enum is documented as struct, union, or enum with the name of the typedef. So @@ -578,7 +578,7 @@ SORT_MEMBER_DOCS = YES # this will also influence the order of the classes in the class list. # The default value is: NO. -SORT_BRIEF_DOCS = NO +SORT_BRIEF_DOCS = YES # If the SORT_MEMBERS_CTORS_1ST tag is set to YES then doxygen will sort the # (brief and detailed) documentation of class members so that constructors and @@ -790,7 +790,7 @@ WARN_LOGFILE = doxy.log # spaces. See also FILE_PATTERNS and EXTENSION_MAPPING # Note: If this tag is empty the current directory is searched. -INPUT = src src/arith src/memory src/ops +INPUT = src # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses @@ -864,7 +864,7 @@ FILE_PATTERNS = *.c \ # be searched for input files as well. # The default value is: NO. -RECURSIVE = NO +RECURSIVE = YES # The EXCLUDE tag can be used to specify files and/or directories that should be # excluded from the INPUT source files. This way you can easily exclude a diff --git a/Makefile b/Makefile index c368d50..7e5efb4 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) @@ -15,13 +15,14 @@ INDENT_FLAGS := -nbad -bap -nbc -br -brf -brs -c33 -cd33 -ncdb -ce -ci4 -cli4 \ -d0 -di1 -nfc1 -i4 -ip0 -l75 -lp -npcs \ -npsl -nsc -nsob -nss -nut -prs -l79 -ts2 -VERSION := "0.0.2" - CPPFLAGS ?= $(INC_FLAGS) -MMD -MP -g -DDEBUG -LDFLAGS := -lm +LDFLAGS := -lm -lcurl +DEBUGFLAGS := -g3 + +all: $(TARGET) $(TARGET): $(OBJS) Makefile - $(CC) $(LDFLAGS) $(OBJS) -DVERSION=$(VERSION) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) + $(CC) $(DEBUGFLAGS) $(LDFLAGS) $(OBJS) -o $@ $(LDFLAGS) $(LOADLIBES) $(LDLIBS) doc: $(SRCS) Makefile Doxyfile doxygen @@ -38,7 +39,7 @@ test: $(OBJS) $(TESTS) Makefile .PHONY: clean clean: - $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~ + $(RM) $(TARGET) $(OBJS) $(DEPS) $(SRC_DIRS)/*~ $(SRC_DIRS)/*/*~ *~ core repl: $(TARGET) -p 2> psse.log diff --git a/README.md b/README.md index caa6375..145b870 100644 --- a/README.md +++ b/README.md @@ -1,8 +1,36 @@ # Post Scarcity Software System, version 0 -Very Nearly a Big Lisp Environment +tl,dr: look at the [wiki](wiki). -tl,dr: look at the [[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]] 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! ## Introduction @@ -16,6 +44,349 @@ 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 new file mode 100644 index 0000000..7cdbcb0 --- /dev/null +++ b/docs/How-do-we-notate-paths.md @@ -0,0 +1,89 @@ +# 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 new file mode 100644 index 0000000..5bb6ca8 --- /dev/null +++ b/docs/Hybrid-assoc-lists.md @@ -0,0 +1,40 @@ +# 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 cec893b..a6d80f5 100644 --- a/lisp/defun.lisp +++ b/lisp/defun.lisp @@ -9,6 +9,11 @@ (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/lisp/expt.lisp b/lisp/expt.lisp new file mode 100644 index 0000000..8b32252 --- /dev/null +++ b/lisp/expt.lisp @@ -0,0 +1,8 @@ +(set! expt (lambda + (n x) + "Return the value of `n` raised to the `x`th power." + (cond + ((= x 1) n) + (t (* n (expt n (- x 1))))))) + +(inspect (expt 2 60)) diff --git a/lisp/fact.lisp b/lisp/fact.lisp index 2f578a6..86d452a 100644 --- a/lisp/fact.lisp +++ b/lisp/fact.lisp @@ -1,4 +1,7 @@ (set! fact (lambda (n) + "Compute the factorial of `n`, expected to be an integer." (cond ((= n 1) 1) (t (* n (fact (- n 1))))))) + +(fact 1000) diff --git a/lisp/not-working-yet.lisp b/lisp/not-working-yet.lisp new file mode 100644 index 0000000..0f3a8c2 --- /dev/null +++ b/lisp/not-working-yet.lisp @@ -0,0 +1,6 @@ +(set! or (lambda values + "True if any of `values` are non-nil." + (cond + ((nil? values) nil) + ((car values) t) + (t (eval (cons 'or (cdr values))))))) diff --git a/lisp/scratchpad.lisp b/lisp/scratchpad.lisp new file mode 100644 index 0000000..0474099 --- /dev/null +++ b/lisp/scratchpad.lisp @@ -0,0 +1,48 @@ +(set! i + (+ + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000 + 10000000000000000000)) + +(set! j (+ i i i i i i i i i i)) + +(set! k (+ j j j j j j j j j j)) + +(set! l (+ k k k k k k k k k k)) + +(set! m (+ l l l l l l l l l l)) + +(set! n (+ m m m m m m m m m m)) + +(set! o (+ n n n n n n n n n n)) + +(set! p (+ o o o o o o o o o o)) + +(set! q (+ p p p p p p p p p p)) + +(set! r (+ q q q q q q q q q q)) + +(set! s (+ r r r r r r r r r r)) + +(set! t (+ s s s s s s s s s s)) + +(set! u (+ t t t t t t t t t t)) + +(set! v (+ u u u u u u u u u u)) + +(set! x (+ v v v v v v v v v v)) + +(set! y (+ x x x x x x x x x x)) + +"we're OK to here: 10^36, which is below the 2^120 barrier so represented as two cells" +(inspect (set! z (+ y y y y y y y y y y))) + +"This blows up: 10^37, which is a three cell bignum." +(inspect (set! final (+ z z z z z z z z z z))) diff --git a/lisp/scratchpad2.lisp b/lisp/scratchpad2.lisp new file mode 100644 index 0000000..65f7aca --- /dev/null +++ b/lisp/scratchpad2.lisp @@ -0,0 +1,85 @@ +"This demonstrates that although the print representation of three cell bignums blows up, the internal representation is sane" + +"We start by adding 8 copies of 2^60 - i.e. the first two-cell integer" + +(set! a + (+ + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976 + 1152921504606846976)) + +"Then repeatedly add eight copies of the previous generation" + +(set! b (+ a a a a a a a a)) + +(set! c (+ b b b b b b b b)) + +(set! d (+ c c c c c c c c)) + +(set! e (+ d d d d d d d d)) + +(set! f (+ e e e e e e e e)) + +(set! g (+ f f f f f f f f)) + +(set! h (+ g g g g g g g g)) + +(set! i (+ h h h h h h h h)) + +(set! j (+ i i i i i i i i)) + +(set! k (+ j j j j j j j j)) + +(set! l (+ k k k k k k k k)) + +(set! m (+ l l l l l l l l)) + +(set! n (+ m m m m m m m m)) + +(set! o (+ n n n n n n n n)) + +"p" +(set! p (+ o o o o o o o o)) + +"q" +(set! q (+ p p p p p p p p)) + +"r" +(set! r (+ q q q q q q q q)) + +"s" +(inspect + (set! s (+ r r r r r r r r))) + +"t - first three cell integer. Printing blows up here" +(inspect + (set! t (+ s s s s s s s s))) + +"u" +(inspect + (set! u (+ t t t t t t t t))) + +"v" +(inspect + (set! v (+ u u u u u u u u))) + +"w" +(inspect + (set! w (+ v v v v v v v v))) + +(inspect + (set! x (+ w w w w w w w w))) + +(inspect + (set! y (+ x x x x x x x x))) + +(inspect + (set! z (+ y y y y y y y y))) + +(inspect + (set! final (+ z z z z z z z z))) diff --git a/lisp/slurp.lisp b/lisp/slurp.lisp new file mode 100644 index 0000000..e927bcb --- /dev/null +++ b/lisp/slurp.lisp @@ -0,0 +1 @@ +(slurp (set! f (open "http://www.journeyman.cc/"))) diff --git a/lisp/types.lisp b/lisp/types.lisp new file mode 100644 index 0000000..7f7bf8c --- /dev/null +++ b/lisp/types.lisp @@ -0,0 +1,17 @@ +(set! cons? (lambda (o) "True if o is a cons cell." (= (type o) "CONS") ) ) +(set! exception? (lambda (o) "True if o is an exception." (= (type o) "EXEP"))) +(set! free? (lambda (o) "Trus if o is a free cell - this should be impossible!" (= (type o) "FREE"))) +(set! function? (lambda (o) "True if o is a compiled function." (= (type o) "EXEP"))) +(set! integer? (lambda (o) "True if o is an integer." (= (type o) "INTR"))) +(set! lambda? (lambda (o) "True if o is an interpreted (source) function." (= (type o) "LMDA"))) +(set! nil? (lambda (o) "True if o is the canonical nil value." (= (type o) "NIL "))) +(set! nlambda? (lambda (o) "True if o is an interpreted (source) special form." (= (type o) "NLMD"))) +(set! rational? (lambda (o) "True if o is an rational number." (= (type o) "RTIO"))) +(set! read? (lambda (o) "True if o is a read stream." (= (type o) "READ") ) ) +(set! real? (lambda (o) "True if o is an real number." (= (type o) "REAL"))) +(set! special? (lambda (o) "True if o is a compiled special form." (= (type o) "SPFM") ) ) +(set! string? (lambda (o) "True if o is a string." (= (type o) "STRG") ) ) +(set! symbol? (lambda (o) "True if o is a symbol." (= (type o) "SYMB") ) ) +(set! true? (lambda (o) "True if o is the canonical true value." (= (type o) "TRUE") ) ) +(set! write? (lambda (o) "True if o is a write stream." (= (type o) "WRIT") ) ) + diff --git a/notes/bignums.md b/notes/bignums.md new file mode 100644 index 0000000..f77653c --- /dev/null +++ b/notes/bignums.md @@ -0,0 +1,7 @@ +# All integers are potentially bignums + +Each integer comprises at least one cell of type INTR, holding a signed 64 bit integer with a value in the range 0 ... MAX-INTEGER, where the actual value of MAX-INTEGER does not need to be the same as the C language LONG\_MAX, provided that it is less than this. It seems to me that a convenient number would be the largest number less than LONG\_MAX which has all bits set + +LONG\_MAX is 0x7FFFFFFFFFFFFFFF, so the number we're looking for is 0x0FFFFFFFFFFFFFFF, which is 1,152,921,504,606,846,975, which is 2^60 - 1. This means we can use bit masking with 0xFFFFFFFFFFFFFFF to extract the part of **int64_t** which will fit in a single cell. + +It also means that if we multiply two **int64_t**s into an **__int128_t**, we can then right-shift by 60 places to get the carry. diff --git a/notes/connection-machine.txt b/notes/connection-machine.md similarity index 100% rename from notes/connection-machine.txt rename to notes/connection-machine.md diff --git a/notes/mad-software.md b/notes/mad-software.md new file mode 100644 index 0000000..bbe8092 --- /dev/null +++ b/notes/mad-software.md @@ -0,0 +1,75 @@ +# Mad software + +I was listening to [Eric Normand's podcast](https://lispcast.com/tension-between-data-and-entity/) this morning, as I was making breakfast and tidying my room; he was talking about semantics and data. It started a train of thought which I shall try to unroll. + +I have blogged a lot in the past about madness and about software, but I don't think I've ever blogged about madness and software in the same essay. But the reasons I'm mad and the reasons I'm (sometimes) very good at software are related; both have their roots in autism and dyslexia, or, to put it differently, how my brain is wired. + +I first wrote about [post scarcity software](https://blog.journeyman.cc/2006/02/post-scarcity-software.html) thirteen years ago. It was a thought about how software environments should be designed if were weren't held back by the cruft of the past, by tradition and by a lack, frankly, of anything much in the way of new creative thought. And seeing that the core of the system I described is a Lisp, which is to say it builds on a software architecture which is exactly as old as I am, perhaps it is infected by my take on tradition and my own lack of creativity, but let's, for the purposes of this essay, assume not. + +I started actually writing the [post scarcity software environment](https://github.com/simon-brooke/post-scarcity) on the second of January 2017, which is to say two years ago. It's been an extremely low priority task, because I don't have enough faith in either my vision or my skill to think that it will ever be of use to anyone. Nevertheless, it does now actually work, in as much as you can write software in it. It's not at all easy yet, and I wouldn't recommend anyone try, but you can check out the master branch from Github, compile it, and it works. + +As my mental health has deteriorated, I have been working on it more over the past couple of months, partly because I have lost faith in my ability to deliver the more practical projects I've been working on, and partly because doing something which is genuinely intellectually hard helps subdue the chaos in my mind. + +Having said that, it is hard and I am not sharp, and so progress is slow. I started work on big number arithmetic a three weeks ago, and where I'm up to at this point is: + +* addition seems to work up to at least the second bignum boundary; +* multiplication doesn't work beyond the first bignum boundary; +* subraction doesn't work, and turns out not to be as easy as just inverting addition; +* division sort of trivially works, but only in the sense that we can create a rational number out of arbitrary bignums; +* reading works beyond the first bignum boundary, but not up to the second (because multiplication doesn't work); +* printing doesn't work beyond the first bignum boundary. + +I knew bignums were going to be a challenge, and I could have studied other people's bignum code and have consciously chosen not to do so; but this is not fast progress. + +(I should point out that in those three weeks I've also done four days of customer work, which is .Net and boring but it's done, spent two days seeing my sister, spent two days so depressed I didn't actually do anything at all, and done a bit or practical work around the croft. But still!) + +In a sense, it wasn't expected to be. Writing the underpinnings of a software environment which is conceptually without limits has challenge after challenge after challenge. + +But there are ideas in post scarcity which may have wider utility than this mad idea in itself. Layering homogeneities and regularities onto Clojure maps might - perhaps would - make a useful library, might would make a very useful component for exactly the sort of data wrangling Eric Normand was talking about. Yes, you can use a map - raw data soup - to represent a company. But if this map is a member of a homogeneity, 'Companies', then we know every member of it has employees, and that every employee has a salary and an email address. Regularities and homogeneities form the building blocks of APIs; to use the example Eric discussed in his podcast, the salary is the property of the employee, but the payroll is a property of the company. So in post scarcity, you'd get the payroll figure for a company by using a method on the 'Companies' homogeneity. How it computes that value is part of the general doctrine of **'Don't Know, Don't Care'**: the principal that people writing software at any layer in the system do not need to know, and should not need to care, about how things are implemented in the layers below them. + + + +So, the user needing to find the payroll value would enter something like this: + +``` + (with ((companies . ::shared:pool:companies) + (acme . companies:acme-widgets)) + (companies:methods:payroll acme)) +``` + +In practice, in post scarcity notation, the payroll method probably looks something like this: + +``` + (lambda (company) + (reduce + (map ::shared:pool:employees:methods:salary (:employees company)))) +``` + +There are issues that I haven't resolved yet about the mutability of regularities and homogeneities; obviously, in order to provide multi-user visibility of current values of shared data, some regularities must be mutable. But mutability has potentially very serious perfomance issues for the hypercube architecture, so I think that in general they should not be. + +However, that's detail, and not what I'm trying to talk about here. + +What I'm trying to talk about here is the fact that if I were confident that these ideas were any good, and that I had the ability to persuade others that they were any good, it would make far more sense to implement them in Clojure and promote them as a library. + +But the problem with depression is that you cannot evaluate whether your ideas are any good. The black dog tells you you're shit, and that your ideas are shit, and that you don't really know enough to be worth listening to, and that you're an old tramp who lives in a hut in the woods, and probably smells, and that in any case interaction with other people quickly makes you shaky and confused, and that you can never get your act together, and you never finish anything. + +And all that is objectively true, and I know that it is true. But I also know that I can (or at least have in the past been able to) build really good software, and that I can (or have been able, in the past, to) present ideas really well. + +These two collections of statements about me are both true at the same time. But the difference is that I believe the first and I don't believe the second. + +And behind all this is the fact that bignum arithmetic is a solved problem. I could dig out the SBCL source code and crib from that. I am bashing my head against bignum arithmetic and trying to solve it myself, not because it's the most efficient way to produce good code quickly, but because what I'm really trying to do is just distract myself and waste time while I can get on with dying. + +And the reason beyond that that I'm working on a software system I know I'll never finish, which is designed to run on computers which don't even exist yet - and although I'm very confident that enormously parallel hardware will be used in future, I'm not at all sure it will look anything like what I'm envisaging - the reason I'm building this mad software is that, because it will never be finished, no-one will ever use it except me, and no-one will say how crap it is and how easily it could have been done better. + +Because the other thing that I'm doing in writing this stuff, apart from distracting from the swirling chaos and rage in my head, apart from waiting to die, the other thing I'm doing is trying to give myself a feeling of mastery, of competence, of ability to face problems and solve them. And, to an extent, it works. But I have so little confidence that I actually have that mastery, that competence, that I don't want to expose it to criticism. I don't want my few fragile rags of self worth stripped away. + +And so I work, and work, and work at something which is so arcane, so obscure, so damned pointless that no-one will ever use it. + +Not because I'm even enjoying it, but just to burn the time. + +This is mad. + +I am mad. + +I hate, hate, hate being mad. + +Postscript: just writing this essay has made me tearful, headachey, sick, shaky. It's very hard to face up to the irrationalities and self-deceptions in one's own behaviour. diff --git a/notes/psh-architecture.txt b/notes/psh-architecture.md similarity index 100% rename from notes/psh-architecture.txt rename to notes/psh-architecture.md diff --git a/src/arith/bignum.c b/src/arith/bignum.c deleted file mode 100644 index a21a7df..0000000 --- a/src/arith/bignum.c +++ /dev/null @@ -1,14 +0,0 @@ -/* - * bignum.c - * - * Allocation of and operations on arbitrary precision integers. - * - * (c) 2018 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -/* - * Bignums generally follow Knuth, vol 2, 4.3. The word size is 64 bits, - * and words are stored in individual cons-space objects, comprising the - * word itself and a pointer to the next word in the number. - */ diff --git a/src/arith/bignum.h b/src/arith/bignum.h deleted file mode 100644 index 05c9073..0000000 --- a/src/arith/bignum.h +++ /dev/null @@ -1,16 +0,0 @@ -/** - * bignum.h - * - * functions for bignum cells. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#ifndef __bignum_h -#define __bignum_h - - - -#endif diff --git a/src/arith/integer.c b/src/arith/integer.c index 5239746..eef171b 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -8,40 +8,424 @@ */ #define _GNU_SOURCE +#include #include #include +#include +/* + * wide characters + */ +#include +#include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" +#include "ops/equal.h" +#include "ops/lispops.h" +#include "arith/peano.h" /** - * return the numeric value of this cell, as a C primitive double, not - * as a cons-space object. Cell may in principle be any kind of number, - * but only integers and reals are so far implemented. + * hexadecimal digits for printing numbers. */ -long double numeric_value( struct cons_pointer pointer ) { - long double result = NAN; - struct cons_space_object *cell = &pointer2cell( pointer ); +const char *hex_digits = "0123456789ABCDEF"; - if ( integerp( pointer ) ) { - result = cell->payload.integer.value * 1.0; - } else if ( realp( pointer ) ) { - result = cell->payload.real.value; +/* + * Doctrine from here on in is that ALL integers are bignums, it's just + * that integers less than 65 bits are bignums of one cell only. + */ + +/** + * Allocate an integer cell representing this `value` and return a cons_pointer to it. + * @param value an integer value; + * @param more `NIL`, or a pointer to the more significant cell(s) of this number. + * *NOTE* that if `more` is not `NIL`, `value` *must not* exceed `MAX_INTEGER`. + */ +struct cons_pointer make_integer( int64_t value, struct cons_pointer more ) { + struct cons_pointer result = NIL; + debug_print( L"Entering make_integer\n", DEBUG_ALLOC ); + + if ( integerp( more ) || nilp( more ) ) { + result = allocate_cell( INTEGERTV ); + struct cons_space_object *cell = &pointer2cell( result ); + cell->payload.integer.value = value; + cell->payload.integer.more = more; + } + + debug_print( L"make_integer: returning\n", DEBUG_ALLOC ); + debug_dump_object( result, DEBUG_ALLOC ); + return result; +} + +/** + * Low level integer arithmetic, do not use elsewhere. + * + * @param c a pointer to a cell, assumed to be an integer cell; + * @param op a character representing the operation: expectedto be either + * '+' or '*'; behaviour with other values is undefined. + * @param is_first_cell true if this is the first cell in a bignum + * chain, else false. + * \see multiply_integers + * \see add_integers + */ +__int128_t cell_value( struct cons_pointer c, char op, bool is_first_cell ) { + long int val = nilp( c ) ? 0 : pointer2cell( c ).payload.integer.value; + + long int carry = is_first_cell ? 0 : ( MAX_INTEGER + 1 ); + + __int128_t result = ( __int128_t ) integerp( c ) ? + ( val == 0 ) ? carry : val : op == '*' ? 1 : 0; + debug_printf( DEBUG_ARITH, + L"cell_value: raw value is %ld, is_first_cell = %s; '%4.4s'; returning ", + val, is_first_cell ? "true" : "false", + pointer2cell( c ).tag.bytes ); + debug_print_128bit( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + return result; +} + +/** + * Overwrite the value field of the integer indicated by `new` with + * the least significant 60 bits of `val`, and return the more significant + * bits (if any) right-shifted by 60 places. Destructive, primitive, do not + * use in any context except primitive operations on integers. + * + * @param val the value to represent; + * @param less_significant the less significant words of this bignum, if any, + * else NIL; + * @param new a newly created integer, which will be destructively changed. + * @return carry, if any, else 0. + */ +__int128_t int128_to_integer( __int128_t val, + struct cons_pointer less_significant, + struct cons_pointer new ) { + struct cons_pointer cursor = NIL; + __int128_t carry = 0; + + if ( MAX_INTEGER >= val ) { + carry = 0; + } else { + carry = val >> 60; + debug_printf( DEBUG_ARITH, + L"int128_to_integer: 64 bit overflow; setting carry to %ld\n", + ( int64_t ) carry ); + val &= MAX_INTEGER; + } + + struct cons_space_object *newc = &pointer2cell( new ); + newc->payload.integer.value = val; + + if ( integerp( less_significant ) ) { + struct cons_space_object *lsc = &pointer2cell( less_significant ); + inc_ref( new ); + lsc->payload.integer.more = new; + } + + return carry; +} + +struct cons_pointer make_integer_128( __int128_t val, + struct cons_pointer less_significant ) { + struct cons_pointer result = NIL; + + do { + if ( MAX_INTEGER >= val ) { + result = make_integer( ( long int ) val, less_significant ); + } else { + less_significant = + make_integer( ( long int ) val & MAX_INTEGER, + less_significant ); + val = val >> 60; + } + + } while ( nilp( result ) ); + + return result; +} + +/** + * Return a pointer to an integer representing the sum of the integers + * pointed to by `a` and `b`. If either isn't an integer, will return nil. + */ +struct cons_pointer add_integers( struct cons_pointer a, + struct cons_pointer b ) { + struct cons_pointer result = NIL; + struct cons_pointer cursor = NIL; + + debug_print( L"add_integers: a = ", DEBUG_ARITH ); + debug_print_object( a, DEBUG_ARITH ); + debug_print( L"; b = ", DEBUG_ARITH ); + debug_print_object( b, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + __int128_t carry = 0; + bool is_first_cell = true; + + if ( integerp( a ) && integerp( b ) ) { + debug_print( L"add_integers: \n", DEBUG_ARITH ); + debug_dump_object( a, DEBUG_ARITH ); + debug_print( L" plus \n", DEBUG_ARITH ); + debug_dump_object( b, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + while ( !nilp( a ) || !nilp( b ) || carry != 0 ) { + __int128_t av = cell_value( a, '+', is_first_cell ); + __int128_t bv = cell_value( b, '+', is_first_cell ); + __int128_t rv = av + bv + carry; + + debug_print( L"add_integers: av = ", DEBUG_ARITH ); + debug_print_128bit( av, DEBUG_ARITH ); + debug_print( L"; bv = ", DEBUG_ARITH ); + debug_print_128bit( bv, DEBUG_ARITH ); + debug_print( L"; carry = ", DEBUG_ARITH ); + debug_print_128bit( carry, DEBUG_ARITH ); + debug_print( L"; rv = ", DEBUG_ARITH ); + debug_print_128bit( rv, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); + + struct cons_pointer new = make_integer( 0, NIL ); + carry = int128_to_integer( rv, cursor, new ); + cursor = new; + + if ( nilp( result ) ) { + result = cursor; + } + + a = pointer2cell( a ).payload.integer.more; + b = pointer2cell( b ).payload.integer.more; + is_first_cell = false; + } + } + + debug_print( L"add_integers returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + return result; +} + +struct cons_pointer base_partial( int depth ) { + struct cons_pointer result = NIL; + + for ( int i = 0; i < depth; i++ ) { + result = make_integer( 0, result ); } return result; } /** - * Allocate an integer cell representing this value and return a cons pointer to it. + * destructively modify this `partial` by appending this `digit`. */ -struct cons_pointer make_integer( int64_t value ) { - struct cons_pointer result = allocate_cell( INTEGERTAG ); - struct cons_space_object *cell = &pointer2cell( result ); - cell->payload.integer.value = value; +struct cons_pointer append_digit( struct cons_pointer partial, + struct cons_pointer digit ) { + struct cons_pointer c = partial; + struct cons_pointer result = partial; - debug_dump_object( result, DEBUG_ARITH ); + if ( nilp( partial ) ) { + result = digit; + } else { + while ( !nilp( pointer2cell( c ).payload.integer.more ) ) { + c = pointer2cell( c ).payload.integer.more; + } + + ( &pointer2cell( c ) )->payload.integer.more = digit; + } + return result; +} + + + +/** + * Return a pointer to an integer representing the product of the integers + * pointed to by `a` and `b`. If either isn't an integer, will return nil. + * + * Yes, this is one of Muhammad ibn Musa al-Khwarizmi's original recipes, so + * you'd think it would be easy; the reason that each step is documented is + * because I did not find it so. + * + * @param a an integer; + * @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 ); + bool neg = is_negative( a ) != is_negative( b ); + bool is_first_b = true; + int i = 0; + + debug_print( L"multiply_integers: a = ", DEBUG_ARITH ); + debug_print_object( a, DEBUG_ARITH ); + debug_print( L"; b = ", DEBUG_ARITH ); + debug_print_object( b, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + if ( integerp( a ) && integerp( b ) ) { + /* 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 ) { + /* set carry to 0 */ + __int128_t carry = 0; + + /* set least significant digits for result ri for this iteration + * to i zeros */ + struct cons_pointer ri = base_partial( i++ ); + + /* 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 ) { + + 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 ); + + /* 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; + 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 ); + + /* destructively modify ri by appending dj */ + ri = append_digit( ri, dj ); + } /* end for bj */ + + /* if carry is not equal to zero, append it as a final digit + * to ri */ + if ( carry != 0 ) { + ri = append_digit( ri, make_integer( carry, NIL ) ); + } + + /* add ri to result */ + 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 */ + } + + debug_print( L"multiply_integers returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + + return result; +} + +/** + * don't use; private to integer_to_string, and somewaht dodgy. + */ +struct cons_pointer integer_to_string_add_digit( int digit, int digits, + struct cons_pointer tail ) { + wint_t character = btowc( hex_digits[digit] ); + return ( digits % 3 == 0 ) ? + make_string( L',', make_string( character, + tail ) ) : + make_string( character, tail ); +} + +/** + * The general principle of printing a bignum is that you print the least + * significant digit in whatever base you're dealing with, divide through + * by the base, print the next, and carry on until you've none left. + * Obviously, that means you print from right to left. Given that we build + * strings from right to left, 'printing' an integer to a lisp string + * would seem reasonably easy. The problem is when you jump from one integer + * object to the next. 64 bit integers don't align with decimal numbers, so + * when we get to the last digit from one integer cell, we have potentially + * to be looking to the next. H'mmmm. + */ +struct cons_pointer integer_to_string( struct cons_pointer int_pointer, + 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; + int digits = 0; + + if ( accumulator == 0 && nilp( next ) ) { + result = c_string_to_lisp_string( L"0" ); + } 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; + } + int offset = ( int ) ( accumulator % base ); + debug_printf( DEBUG_IO, + L"integer_to_string: digit is %ld, hexadecimal is %c, accumulator is: ", + offset, hex_digits[offset] ); + debug_print_128bit( accumulator, DEBUG_IO ); + debug_print( L"; result is: ", DEBUG_IO ); + debug_print_object( result, DEBUG_IO ); + debug_println( DEBUG_IO ); + + result = + integer_to_string_add_digit( offset, ++digits, result ); + accumulator = accumulator / base; + } + + if ( stringp( result ) + && pointer2cell( result ).payload.string.character == L',' ) { + /* if the number of digits in the string is divisible by 3, there will be + * an unwanted comma on the front. */ + result = pointer2cell( result ).payload.string.cdr; + } + + + if ( is_negative ) { + result = make_string( L'-', result ); + } + } + } + + 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 00b94a6..09a7a83 100644 --- a/src/arith/integer.h +++ b/src/arith/integer.h @@ -1,4 +1,4 @@ -/** +/* * integer.h * * functions for integer cells. @@ -11,11 +11,22 @@ #ifndef __integer_h #define __integer_h -long double numeric_value( struct cons_pointer pointer ); +#include +#include -/** - * Allocate an integer cell representing this value and return a cons pointer to it. - */ -struct cons_pointer make_integer( int64_t value ); +struct cons_pointer make_integer( int64_t value, struct cons_pointer more ); + +struct cons_pointer add_integers( struct cons_pointer a, + struct cons_pointer b ); + +struct cons_pointer multiply_integers( struct cons_pointer a, + struct cons_pointer b ); + +struct cons_pointer integer_to_string( struct cons_pointer int_pointer, + int base ); + +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 9f5e0fb..ae23a00 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -14,18 +14,19 @@ #include #include -#include "consspaceobject.h" -#include "conspage.h" +#include "memory/consspaceobject.h" +#include "memory/conspage.h" #include "debug.h" -#include "equal.h" -#include "integer.h" -#include "intern.h" -#include "lispops.h" -#include "print.h" -#include "ratio.h" -#include "read.h" -#include "real.h" -#include "stack.h" +#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" long double to_long_double( struct cons_pointer arg ); int64_t to_long_int( struct cons_pointer arg ); @@ -34,14 +35,23 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer arg1, struct cons_pointer arg2 ); - +/** + * return true if this `arg` points to a number whose value is zero. + */ bool zerop( struct cons_pointer arg ) { bool result = false; struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { - case INTEGERTV: - result = cell.payload.integer.value == 0; + case INTEGERTV:{ + do { + debug_print( L"zerop: ", DEBUG_ARITH ); + debug_dump_object( arg, DEBUG_ARITH ); + result = + ( pointer2cell( arg ).payload.integer.value == 0 ); + arg = pointer2cell( arg ).payload.integer.more; + } while ( result && integerp( arg ) ); + } break; case RATIOTV: result = zerop( cell.payload.ratio.dividend ); @@ -55,29 +65,86 @@ bool zerop( struct cons_pointer arg ) { } /** - * TODO: cannot throw an exception out of here, which is a problem - * if a ratio may legally have zero as a divisor, or something which is - * not a number is passed in. + * does this `arg` point to a negative number? */ -long double to_long_double( struct cons_pointer arg ) { - long double result = 0; /* not a number, as a long double */ +bool is_negative( struct cons_pointer arg ) { + bool result = false; struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { case INTEGERTV: - result = ( double ) cell.payload.integer.value; + result = cell.payload.integer.value < 0; break; case RATIOTV: - { - struct cons_space_object dividend = - pointer2cell( cell.payload.ratio.dividend ); - struct cons_space_object divisor = - pointer2cell( cell.payload.ratio.divisor ); + result = is_negative( cell.payload.ratio.dividend ); + break; + case REALTV: + result = ( cell.payload.real.value < 0 ); + break; + } + return result; +} + +struct cons_pointer absolute( struct cons_pointer arg ) { + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( arg ); + + if ( is_negative( arg ) ) { + switch ( cell.tag.value ) { + case INTEGERTV: result = - ( long double ) dividend.payload.integer.value / - divisor.payload.integer.value; - } + make_integer( llabs( cell.payload.integer.value ), + cell.payload.integer.more ); + break; + case RATIOTV: + result = make_ratio( absolute( cell.payload.ratio.dividend ), + cell.payload.ratio.divisor ); + break; + case REALTV: + result = make_real( 0 - cell.payload.real.value ); + break; + } + } + + return result; +} + +/** + * Return the closest possible `binary64` representation to the value of + * this `arg`, expected to be an integer, ratio or real, or `NAN` if `arg` + * is not any of these. + * + * @arg a pointer to an integer, ratio or real. + * + * \todo cannot throw an exception out of here, which is a problem + * if a ratio may legally have zero as a divisor, or something which is + * not a number is passed in. + */ +long double to_long_double( struct cons_pointer arg ) { + long double result = 0; + struct cons_space_object cell = pointer2cell( arg ); + + switch ( cell.tag.value ) { + case INTEGERTV: + // obviously, this doesn't work for bignums + result = ( long double ) cell.payload.integer.value; + // sadly, this doesn't work at all. +// result += 1.0; +// for (bool is_first = false; integerp(arg); is_first = true) { +// debug_printf(DEBUG_ARITH, L"to_long_double: accumulator = %lf, arg = ", result); +// debug_dump_object(arg, DEBUG_ARITH); +// if (!is_first) { +// result *= (long double)(MAX_INTEGER + 1); +// } +// result *= (long double)(cell.payload.integer.value); +// arg = cell.payload.integer.more; +// cell = pointer2cell( arg ); +// } + break; + case RATIOTV: + result = to_long_double( cell.payload.ratio.dividend ) / + to_long_double( cell.payload.ratio.divisor ); break; case REALTV: result = cell.payload.real.value; @@ -96,7 +163,13 @@ long double to_long_double( struct cons_pointer arg ) { /** - * TODO: cannot throw an exception out of here, which is a problem + * Return the closest possible `int64_t` representation to the value of + * this `arg`, expected to be an integer, ratio or real, or `NAN` if `arg` + * is not any of these. + * + * @arg a pointer to an integer, ratio or real. + * + * \todo cannot throw an exception out of here, which is a problem * if a ratio may legally have zero as a divisor, or something which is * not a number (or is a big number) is passed in. */ @@ -105,6 +178,9 @@ int64_t to_long_int( struct cons_pointer arg ) { struct cons_space_object cell = pointer2cell( arg ); switch ( cell.tag.value ) { case INTEGERTV: + /* \todo if (integerp(cell.payload.integer.more)) { + * throw an exception! + * } */ result = cell.payload.integer.value; break; case RATIOTV: @@ -119,9 +195,25 @@ int64_t to_long_int( struct cons_pointer arg ) { /** -* return a cons_pointer indicating a number which is the sum of -* the numbers indicated by `arg1` and `arg2`. -*/ + * Function: calculate the absolute value of a number. + * + * (absolute arg) + * + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return the absolute value of the number represented by the first + * argument, or NIL if it was not a number. + */ +struct cons_pointer lisp_absolute( struct stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return absolute( frame->arg[0] ); +} + +/** + * return a cons_pointer indicating a number which is the sum of + * the numbers indicated by `arg1` and `arg2`. + */ struct cons_pointer add_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1, @@ -131,9 +223,9 @@ struct cons_pointer add_2( struct stack_frame *frame, struct cons_space_object cell2 = pointer2cell( arg2 ); debug_print( L"add_2( arg1 = ", DEBUG_ARITH ); - debug_print_object( arg1, DEBUG_ARITH ); + debug_dump_object( arg1, DEBUG_ARITH ); debug_print( L"; arg2 = ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); + debug_dump_object( arg2, DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH ); if ( zerop( arg1 ) ) { @@ -152,12 +244,10 @@ struct cons_pointer add_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = make_integer( cell1.payload.integer.value + - cell2.payload.integer.value ); + result = add_integers( arg1, arg2 ); break; case RATIOTV: - result = - add_integer_ratio( frame_pointer, arg1, arg2 ); + result = add_integer_ratio( arg1, arg2 ); break; case REALTV: result = @@ -177,11 +267,10 @@ struct cons_pointer add_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = - add_integer_ratio( frame_pointer, arg2, arg1 ); + result = add_integer_ratio( arg2, arg1 ); break; case RATIOTV: - result = add_ratio_ratio( frame_pointer, arg1, arg2 ); + result = add_ratio_ratio( arg1, arg2 ); break; case REALTV: result = @@ -219,12 +308,13 @@ struct cons_pointer add_2( struct stack_frame *frame, * Add an indefinite number of numbers together * @param env the evaluation environment - ignored; * @param frame the stack frame. - * @return a pointer to an integer or real. + * @return a pointer to an integer, ratio or real. + * @exception if any argument is not a number, returns an exception. */ struct cons_pointer lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer result = make_integer( 0 ); + struct cons_pointer result = make_integer( 0, NIL ); struct cons_pointer tmp; for ( int i = 0; @@ -253,9 +343,9 @@ struct cons_pointer lisp_add( struct stack_frame /** -* return a cons_pointer indicating a number which is the product of -* the numbers indicated by `arg1` and `arg2`. -*/ + * return a cons_pointer indicating a number which is the product of + * the numbers indicated by `arg1` and `arg2`. + */ struct cons_pointer multiply_2( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer arg1, @@ -268,7 +358,7 @@ struct cons_pointer multiply_2( struct stack_frame *frame, debug_print_object( arg1, DEBUG_ARITH ); debug_print( L"; arg2 = ", DEBUG_ARITH ); debug_print_object( arg2, DEBUG_ARITH ); - debug_print( L")", DEBUG_ARITH ); + debug_print( L")\n", DEBUG_ARITH ); if ( zerop( arg1 ) ) { result = arg2; @@ -285,13 +375,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = make_integer( cell1.payload.integer.value * - cell2.payload.integer.value ); + result = multiply_integers( arg1, arg2 ); break; case RATIOTV: - result = - multiply_integer_ratio( frame_pointer, arg1, - arg2 ); + result = multiply_integer_ratio( arg1, arg2 ); break; case REALTV: result = @@ -299,9 +386,12 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: not a number" ), - frame_pointer ); + result = + throw_exception( make_cons + ( c_string_to_lisp_string + ( L"Cannot multiply: argument 2 is not a number: " ), + c_type( arg2 ) ), + frame_pointer ); break; } break; @@ -311,13 +401,10 @@ struct cons_pointer multiply_2( struct stack_frame *frame, result = arg2; break; case INTEGERTV: - result = - multiply_integer_ratio( frame_pointer, arg2, - arg1 ); + result = multiply_integer_ratio( arg2, arg1 ); break; case RATIOTV: - result = - multiply_ratio_ratio( frame_pointer, arg1, arg2 ); + result = multiply_ratio_ratio( arg1, arg2 ); break; case REALTV: result = @@ -325,9 +412,12 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: not a number" ), - frame_pointer ); + result = + throw_exception( make_cons + ( c_string_to_lisp_string + ( L"Cannot multiply: argument 2 is not a number" ), + c_type( arg2 ) ), + frame_pointer ); } break; case REALTV: @@ -336,66 +426,67 @@ struct cons_pointer multiply_2( struct stack_frame *frame, to_long_double( arg2 ) ); break; default: - result = throw_exception( c_string_to_lisp_string - ( L"Cannot multiply: not a number" ), + result = throw_exception( make_cons( c_string_to_lisp_string + ( L"Cannot multiply: argument 1 is not a number" ), + c_type( arg1 ) ), frame_pointer ); break; } } - debug_print( L" => ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); + debug_print( L"multiply_2 returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); debug_print( L"\n", DEBUG_ARITH ); return result; } +#define multiply_one_arg(arg) {if (exceptionp(arg)){result=arg;}else{tmp = result; result = multiply_2( frame, frame_pointer, result, arg ); if ( !eq( tmp, result ) ) dec_ref( tmp );}} /** * Multiply an indefinite number of numbers together * @param env the evaluation environment - ignored; * @param frame the stack frame. - * @return a pointer to an integer or real. + * @return a pointer to an integer, ratio or real. + * @exception if any argument is not a number, returns an exception. */ struct cons_pointer lisp_multiply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer result = make_integer( 1 ); + struct cons_pointer result = make_integer( 1, NIL ); struct cons_pointer tmp; for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ) && !exceptionp( result ); i++ ) { - tmp = result; - result = multiply_2( frame, frame_pointer, result, frame->arg[i] ); + debug_print( L"lisp_multiply: accumulator = ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_print( L"; arg = ", DEBUG_ARITH ); + debug_print_object( frame->arg[i], DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); - if ( !eq( tmp, result ) ) { - dec_ref( tmp ); - } + multiply_one_arg( frame->arg[i] ); } struct cons_pointer more = frame->more; while ( consp( more ) && !exceptionp( result ) ) { - tmp = result; - result = multiply_2( frame, frame_pointer, result, c_car( more ) ); - - if ( !eq( tmp, result ) ) { - dec_ref( tmp ); - } - + multiply_one_arg( c_car( more ) ); more = c_cdr( more ); } + debug_print( L"lisp_multiply returning: ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_println( DEBUG_ARITH ); + return result; } /** * return a cons_pointer indicating a number which is the - * inverse of the number indicated by `arg`. + * 0 - the number indicated by `arg`. */ -struct cons_pointer inverse( struct cons_pointer frame, - struct cons_pointer arg ) { +struct cons_pointer negative( struct cons_pointer arg ) { struct cons_pointer result = NIL; struct cons_space_object cell = pointer2cell( arg ); @@ -404,16 +495,15 @@ struct cons_pointer inverse( struct cons_pointer frame, result = arg; break; case INTEGERTV: - result = make_integer( 0 - to_long_int( arg ) ); + result = + make_integer( 0 - cell.payload.integer.value, + cell.payload.integer.more ); break; case NILTV: result = TRUE; break; case RATIOTV: - result = make_ratio( frame, - make_integer( 0 - - to_long_int( cell.payload. - ratio.dividend ) ), + result = make_ratio( negative( cell.payload.ratio.dividend ), cell.payload.ratio.divisor ); break; case REALTV: @@ -429,47 +519,63 @@ struct cons_pointer inverse( struct cons_pointer frame, /** - * Subtract one number from another. + * Function: is this number negative? + * + * * (negative? arg) + * * @param env the evaluation environment - ignored; * @param frame the stack frame. - * @return a pointer to an integer or real. + * @return T if the first argument was a negative number, or NIL if it + * was not. */ -struct cons_pointer lisp_subtract( struct - stack_frame - *frame, struct cons_pointer frame_pointer, struct - cons_pointer env ) { - struct cons_pointer result = NIL; - struct cons_space_object cell0 = pointer2cell( frame->arg[0] ); - struct cons_space_object cell1 = pointer2cell( frame->arg[1] ); +struct cons_pointer lisp_is_negative( struct stack_frame + *frame, + struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return is_negative( frame->arg[0] ) ? TRUE : NIL; +} - switch ( cell0.tag.value ) { + +/** + * return a cons_pointer indicating a number which is the result of + * subtracting the number indicated by `arg2` from that indicated by `arg1`, + * in the context of this `frame`. + */ +struct cons_pointer subtract_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ) { + struct cons_pointer result = NIL; + + switch ( pointer2cell( arg1 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[0]; + result = arg1; break; case INTEGERTV: - switch ( cell1.tag.value ) { + switch ( pointer2cell( arg2 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[1]; + result = arg2; break; - case INTEGERTV: - result = make_integer( cell0.payload.integer.value - - cell1.payload.integer.value ); + case INTEGERTV:{ + struct cons_pointer i = negative( arg2 ); + inc_ref( i ); + result = add_integers( arg1, i ); + dec_ref( i ); + } break; case RATIOTV:{ - struct cons_pointer tmp = - make_ratio( frame_pointer, frame->arg[0], - make_integer( 1 ) ); + struct cons_pointer tmp = make_ratio( arg1, + make_integer( 1, + NIL ) ); inc_ref( tmp ); - result = - subtract_ratio_ratio( frame_pointer, tmp, - frame->arg[1] ); + result = subtract_ratio_ratio( tmp, arg2 ); dec_ref( tmp ); } break; case REALTV: result = - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + make_real( to_long_double( arg1 ) - + to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -479,30 +585,26 @@ struct cons_pointer lisp_subtract( struct } break; case RATIOTV: - switch ( cell1.tag.value ) { + switch ( pointer2cell( arg2 ).tag.value ) { case EXCEPTIONTV: - result = frame->arg[1]; + result = arg2; break; case INTEGERTV:{ - struct cons_pointer tmp = - make_ratio( frame_pointer, frame->arg[1], - make_integer( 1 ) ); + struct cons_pointer tmp = make_ratio( arg2, + make_integer( 1, + NIL ) ); inc_ref( tmp ); - result = - subtract_ratio_ratio( frame_pointer, frame->arg[0], - tmp ); + result = subtract_ratio_ratio( arg1, tmp ); dec_ref( tmp ); } break; case RATIOTV: - result = - subtract_ratio_ratio( frame_pointer, frame->arg[0], - frame->arg[1] ); + result = subtract_ratio_ratio( arg1, arg2 ); break; case REALTV: result = - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + make_real( to_long_double( arg1 ) - + to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -512,9 +614,8 @@ struct cons_pointer lisp_subtract( struct } break; case REALTV: - result = exceptionp( frame->arg[1] ) ? frame->arg[1] : - make_real( to_long_double( frame->arg[0] ) - - to_long_double( frame->arg[1] ) ); + result = exceptionp( arg2 ) ? arg2 : + make_real( to_long_double( arg1 ) - to_long_double( arg2 ) ); break; default: result = throw_exception( c_string_to_lisp_string @@ -529,10 +630,27 @@ struct cons_pointer lisp_subtract( struct } /** - * Divide one number by another. + * Subtract one number from another. If more than two arguments are passed + * in the frame, the additional arguments are ignored. + * @param env the evaluation environment - ignored; + * @param frame the stack frame. + * @return a pointer to an integer, ratio or real. + * @exception if either argument is not a number, returns an exception. + */ +struct cons_pointer lisp_subtract( struct + stack_frame + *frame, struct cons_pointer frame_pointer, struct + cons_pointer env ) { + return subtract_2( frame, frame_pointer, frame->arg[0], frame->arg[1] ); +} + +/** + * Divide one number by another. If more than two arguments are passed + * in the frame, the additional arguments are ignored. * @param env the evaluation environment - ignored; * @param frame the stack frame. * @return a pointer to an integer or real. + * @exception if either argument is not a number, returns an exception. */ struct cons_pointer lisp_divide( struct stack_frame @@ -553,23 +671,22 @@ struct cons_pointer lisp_divide( struct break; case INTEGERTV:{ struct cons_pointer unsimplified = - make_ratio( frame_pointer, frame->arg[0], + make_ratio( frame->arg[0], frame->arg[1] ); /* OK, if result may be unsimplified, we should not inc_ref it * - but if not, we should dec_ref it. */ - result = simplify_ratio( frame_pointer, unsimplified ); + result = simplify_ratio( unsimplified ); if ( !eq( unsimplified, result ) ) { dec_ref( unsimplified ); } } break; case RATIOTV:{ - struct cons_pointer one = make_integer( 1 ); + struct cons_pointer one = make_integer( 1, NIL ); struct cons_pointer ratio = - make_ratio( frame_pointer, frame->arg[0], one ); - result = - divide_ratio_ratio( frame_pointer, ratio, - frame->arg[1] ); + make_ratio( frame->arg[0], one ); + inc_ref( ratio ); + result = divide_ratio_ratio( ratio, frame->arg[1] ); dec_ref( ratio ); } break; @@ -591,22 +708,19 @@ struct cons_pointer lisp_divide( struct result = frame->arg[1]; break; case INTEGERTV:{ - struct cons_pointer one = make_integer( 1 ); + struct cons_pointer one = make_integer( 1, NIL ); inc_ref( one ); struct cons_pointer ratio = - make_ratio( frame_pointer, frame->arg[1], one ); + make_ratio( frame->arg[1], one ); inc_ref( ratio ); - result = - divide_ratio_ratio( frame_pointer, frame->arg[0], - ratio ); + result = divide_ratio_ratio( frame->arg[0], ratio ); dec_ref( ratio ); dec_ref( one ); } break; case RATIOTV: result = - divide_ratio_ratio( frame_pointer, frame->arg[0], - frame->arg[1] ); + divide_ratio_ratio( frame->arg[0], frame->arg[1] ); break; case REALTV: result = diff --git a/src/arith/peano.h b/src/arith/peano.h index f1c21b4..3076391 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -1,4 +1,4 @@ -/** +/* * peano.h * * Basic peano arithmetic @@ -12,53 +12,53 @@ #ifndef PEANO_H #define PEANO_H -#ifdef __cplusplus -extern "C" { -#endif - /** - * Add an indefinite number of numbers together - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. + * The maximum value we will allow in an integer cell. */ - struct cons_pointer - lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +#define MAX_INTEGER ((__int128_t)0x0fffffffffffffffL) -/** - * Multiply an indefinite number of numbers together - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ - struct cons_pointer - lisp_multiply( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +bool zerop( struct cons_pointer arg ); -/** - * Subtract one number from another. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ - struct cons_pointer - lisp_subtract( struct stack_frame *frame, - struct cons_pointer frame_pointer, - struct cons_pointer env ); +struct cons_pointer negative( struct cons_pointer arg ); -/** - * Divide one number by another. - * @param env the evaluation environment - ignored; - * @param frame the stack frame. - * @return a pointer to an integer or real. - */ - struct cons_pointer - lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, - struct cons_pointer env ); +bool is_negative( struct cons_pointer arg ); -#ifdef __cplusplus -} -#endif -#endif /* PEANO_H */ +struct cons_pointer absolute( struct cons_pointer 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 ); + +struct cons_pointer +lisp_add( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); + +struct cons_pointer lisp_is_negative( struct stack_frame + *frame, + struct cons_pointer frame_pointer, struct + cons_pointer env ); + +struct cons_pointer +lisp_multiply( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); + +struct cons_pointer negative( struct cons_pointer arg ); + +struct cons_pointer subtract_2( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer arg1, + struct cons_pointer arg2 ); + +struct cons_pointer +lisp_subtract( struct stack_frame *frame, + struct cons_pointer frame_pointer, struct cons_pointer env ); + +struct cons_pointer +lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); + +#endif /* PEANO_H */ diff --git a/src/arith/ratio.c b/src/arith/ratio.c index ca83335..5135d6b 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -11,23 +11,17 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "equal.h" -#include "integer.h" -#include "lispops.h" -#include "print.h" -#include "ratio.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" -/* - * declared in peano.c, can't include piano.h here because - * circularity. TODO: refactor. - */ -struct cons_pointer inverse( struct cons_pointer frame_pointer, - struct cons_pointer arg ); - /** * return, as a int64_t, the greatest common divisor of `m` and `n`, */ @@ -49,51 +43,46 @@ int64_t least_common_multiple( int64_t m, int64_t n ) { return m / greatest_common_divisor( m, n ) * n; } -/** - * return a cons_pointer indicating a number which is of the - * same value as the ratio indicated by `arg`, but which may - * be in a simplified representation. If `arg` isn't a ratio, - * will throw exception. - */ -struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg ) { - struct cons_pointer result = arg; +struct cons_pointer simplify_ratio( struct cons_pointer pointer ) { + struct cons_pointer result = pointer; + struct cons_space_object cell = pointer2cell( pointer ); + struct cons_space_object dividend = + pointer2cell( cell.payload.ratio.dividend ); + struct cons_space_object divisor = + pointer2cell( cell.payload.ratio.divisor ); - if ( ratiop( 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 ( divisor.payload.integer.value == 1 ) { + result = pointer2cell( pointer ).payload.ratio.dividend; + } else { + if ( ratiop( pointer ) ) { + int64_t ddrv = dividend.payload.integer.value, + drrv = divisor.payload.integer.value, + gcd = greatest_common_divisor( ddrv, drrv ); - if ( gcd > 1 ) { - if ( drrv / gcd == 1 ) { - result = make_integer( ddrv / gcd ); - } else { - result = - make_ratio( frame_pointer, make_integer( ddrv / gcd ), - make_integer( drrv / gcd ) ); + 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 ) ); + } } } - } else { - result = - throw_exception( make_cons( c_string_to_lisp_string - ( L"Shouldn't happen: bad arg to simplify_ratio" ), - arg ), frame_pointer ); } return result; -} +} /** * return a cons_pointer indicating a number which is the sum of - * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, - * this is going to break horribly. + * the ratios indicated by `arg1` and `arg2`. + * @exception will return an exception if either `arg1` or `arg2` is not a + * rational number. */ -struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer r, result; @@ -117,21 +106,21 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, lcm = least_common_multiple( dr1v, dr2v ), m1 = lcm / dr1v, m2 = lcm / dr2v; - debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); + debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, + m1, m2 ); if ( dr1v == dr2v ) { - r = make_ratio( frame_pointer, - make_integer( dd1v + dd2v ), + r = make_ratio( make_integer( dd1v + dd2v, NIL ), cell1.payload.ratio.divisor ); } else { - struct cons_pointer dd1vm = make_integer( dd1v * m1 ), - dr1vm = make_integer( dr1v * m1 ), - dd2vm = make_integer( dd2v * m2 ), - dr2vm = make_integer( dr2v * m2 ), - r1 = make_ratio( frame_pointer, dd1vm, dr1vm ), - r2 = make_ratio( frame_pointer, dd2vm, dr2vm ); + struct cons_pointer dd1vm = make_integer( dd1v * m1, NIL ), + dr1vm = make_integer( dr1v * m1, NIL ), + dd2vm = make_integer( dd2v * m2, NIL ), + dr2vm = make_integer( dr2v * m2, NIL ), + r1 = make_ratio( dd1vm, dr1vm ), + r2 = make_ratio( dd2vm, dr2vm ); - r = add_ratio_ratio( frame_pointer, r1, r2 ); + r = add_ratio_ratio( r1, r2 ); /* because the references on dd1vm, dr1vm, dd2vm and dr2vm were * never incremented except when making r1 and r2, decrementing @@ -140,7 +129,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, dec_ref( r2 ); } - result = simplify_ratio( frame_pointer, r ); + result = simplify_ratio( r ); if ( !eq( r, result ) ) { dec_ref( r ); } @@ -150,7 +139,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, ( L"Shouldn't happen: bad arg to add_ratio_ratio" ), make_cons( arg1, make_cons( arg2, NIL ) ) ), - frame_pointer ); + NIL ); } debug_print( L" => ", DEBUG_ARITH ); @@ -164,18 +153,19 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, /** * return a cons_pointer indicating a number which is the sum of * the intger indicated by `intarg` and the ratio indicated by - * `ratarg`. If you pass other types, this is going to break horribly. + * `ratarg`. + * @exception if either `intarg` or `ratarg` is not of the expected type. */ -struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, - struct cons_pointer intarg, +struct cons_pointer add_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ) { struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { - struct cons_pointer one = make_integer( 1 ), - ratio = make_ratio( frame_pointer, intarg, one ); + // TODO: not longer works + struct cons_pointer one = make_integer( 1, NIL ), + ratio = make_ratio( intarg, one ); - result = add_ratio_ratio( frame_pointer, ratio, ratarg ); + result = add_ratio_ratio( ratio, ratarg ); dec_ref( one ); dec_ref( ratio ); @@ -185,8 +175,7 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, ( L"Shouldn't happen: bad arg to add_integer_ratio" ), make_cons( intarg, make_cons( ratarg, - NIL ) ) ), - frame_pointer ); + NIL ) ) ), NIL ); } return result; @@ -194,19 +183,17 @@ struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, /** * return a cons_pointer to a ratio which represents the value of the ratio - * indicated by `arg1` divided by the ratio indicated by `arg2`. If either - * of these aren't RTIO cells, something horrid will happen and it is YOUR FAULT. + * indicated by `arg1` divided by the ratio indicated by `arg2`. + * @exception will return an exception if either `arg1` or `arg2` is not a + * rational number. */ -struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { - struct cons_pointer i = make_ratio( frame_pointer, - pointer2cell( arg2 ).payload. - ratio.divisor, - pointer2cell( arg2 ).payload. - ratio.dividend ), - result = - multiply_ratio_ratio( frame_pointer, arg1, i ); + // 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 ); dec_ref( i ); @@ -215,12 +202,14 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, /** * return a cons_pointer indicating a number which is the product of - * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, - * this is going to break horribly. + * the ratios indicated by `arg1` and `arg2`. + * @exception will return an exception if either `arg1` or `arg2` is not a + * rational number. */ -struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct +struct cons_pointer multiply_ratio_ratio( 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 ); @@ -243,9 +232,9 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str ddrv = dd1v * dd2v, drrv = dr1v * dr2v; struct cons_pointer unsimplified = - make_ratio( frame_pointer, make_integer( ddrv ), - make_integer( drrv ) ); - result = simplify_ratio( frame_pointer, unsimplified ); + make_ratio( make_integer( ddrv, NIL ), + make_integer( drrv, NIL ) ); + result = simplify_ratio( unsimplified ); if ( !eq( unsimplified, result ) ) { dec_ref( unsimplified ); @@ -254,7 +243,7 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str result = throw_exception( c_string_to_lisp_string ( L"Shouldn't happen: bad arg to multiply_ratio_ratio" ), - frame_pointer ); + NIL ); } return result; @@ -263,17 +252,18 @@ struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, str /** * return a cons_pointer indicating a number which is the product of * the intger indicated by `intarg` and the ratio indicated by - * `ratarg`. If you pass other types, this is going to break horribly. + * `ratarg`. + * @exception if either `intarg` or `ratarg` is not of the expected type. */ -struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, - struct cons_pointer intarg, +struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ) { struct cons_pointer result; if ( integerp( intarg ) && ratiop( ratarg ) ) { - struct cons_pointer one = make_integer( 1 ), - ratio = make_ratio( frame_pointer, intarg, one ); - result = multiply_ratio_ratio( frame_pointer, ratio, ratarg ); + // TODO: no longer works; fix + struct cons_pointer one = make_integer( 1, NIL ), + ratio = make_ratio( intarg, one ); + result = multiply_ratio_ratio( ratio, ratarg ); dec_ref( one ); dec_ref( ratio ); @@ -281,7 +271,7 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, result = throw_exception( c_string_to_lisp_string ( L"Shouldn't happen: bad arg to multiply_integer_ratio" ), - frame_pointer ); + NIL ); } return result; @@ -290,14 +280,14 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, /** * return a cons_pointer indicating a number which is the difference of - * the ratios indicated by `arg1` and `arg2`. If you pass non-ratios, - * this is going to break horribly. + * the ratios indicated by `arg1` and `arg2`. + * @exception will return an exception if either `arg1` or `arg2` is not a + * rational number. */ -struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { - struct cons_pointer i = inverse( frame_pointer, arg2 ), - result = add_ratio_ratio( frame_pointer, arg1, i ); + struct cons_pointer i = negative( arg2 ), + result = add_ratio_ratio( arg1, i ); dec_ref( i ); @@ -306,17 +296,18 @@ struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, /** - * Construct a ratio frame from these two pointers, expected to be integers - * or (later) bignums, in the context of this stack_frame. + * Construct a ratio frame from this `dividend` and `divisor`, expected to + * be integers, in the context of the stack_frame indicated by this + * `frame_pointer`. + * @exception if either `dividend` or `divisor` is not an integer. */ -struct cons_pointer make_ratio( struct cons_pointer frame_pointer, - struct cons_pointer dividend, +struct cons_pointer make_ratio( struct cons_pointer dividend, struct cons_pointer divisor ) { struct cons_pointer result; if ( integerp( dividend ) && integerp( divisor ) ) { inc_ref( dividend ); inc_ref( divisor ); - result = allocate_cell( RATIOTAG ); + result = allocate_cell( RATIOTV ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.ratio.dividend = dividend; cell->payload.ratio.divisor = divisor; @@ -324,10 +315,28 @@ struct cons_pointer make_ratio( struct cons_pointer frame_pointer, result = throw_exception( c_string_to_lisp_string ( L"Dividend and divisor of a ratio must be integers" ), - frame_pointer ); + NIL ); } 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 5a3b0d6..9068bfb 100644 --- a/src/arith/ratio.h +++ b/src/arith/ratio.h @@ -11,36 +11,29 @@ #ifndef __ratio_h #define __ratio_h -struct cons_pointer simplify_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg ); +struct cons_pointer simplify_ratio( struct cons_pointer arg ); -struct cons_pointer add_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer add_integer_ratio( struct cons_pointer frame_pointer, - struct cons_pointer intarg, +struct cons_pointer add_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ); -struct cons_pointer divide_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer multiply_ratio_ratio( struct cons_pointer frame_pointer, struct - cons_pointer arg1, struct +struct cons_pointer multiply_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer multiply_integer_ratio( struct cons_pointer frame_pointer, - struct cons_pointer intarg, +struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ); -struct cons_pointer subtract_ratio_ratio( struct cons_pointer frame_pointer, - struct cons_pointer arg1, +struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ); -struct cons_pointer make_ratio( struct cons_pointer frame_pointer, - struct cons_pointer dividend, +struct cons_pointer make_ratio( 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 84ba899..34d29d0 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 "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "read.h" +#include "io/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( REALTAG ); + struct cons_pointer result = allocate_cell( REALTV ); struct cons_space_object *cell = &pointer2cell( result ); cell->payload.real.value = value; diff --git a/src/authorise.c b/src/authorise.c new file mode 100644 index 0000000..afd730d --- /dev/null +++ b/src/authorise.c @@ -0,0 +1,24 @@ +/* + * 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 new file mode 100644 index 0000000..6c55b32 --- /dev/null +++ b/src/authorise.h @@ -0,0 +1,16 @@ +/* + * 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 b21f4af..233e154 100644 --- a/src/debug.c +++ b/src/debug.c @@ -18,10 +18,11 @@ #include #include -#include "consspaceobject.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "dump.h" -#include "print.h" +#include "memory/dump.h" +#include "io/io.h" +#include "io/print.h" /** * the controlling flags for `debug_print`; set in `init.c`, q.v. @@ -42,6 +43,30 @@ void debug_print( wchar_t *message, int level ) { #endif } +/** + * stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc + */ +void debug_print_128bit( __int128_t n, int level ) { +#ifdef DEBUG + if ( level & verbosity ) { + if ( n == 0 ) { + fwprintf( stderr, L"0" ); + } else { + char str[40] = { 0 }; // log10(1 << 128) + '\0' + char *s = str + sizeof( str ) - 1; // start at the end + while ( n != 0 ) { + if ( s == str ) + return; // never happens + + *--s = "0123456789"[n % 10]; // save last digit + n /= 10; // drop it + } + fwprintf( stderr, L"%s", s ); + } + } +#endif +} + /** * print a line feed to stderr, if `verbosity` matches `level`. * `verbosity is a set of flags, see debug_print.h; so you can @@ -61,15 +86,15 @@ void debug_println( int level ) { * `wprintf` adapted for the debug logging system. Print to stderr only * `verbosity` matches `level`. All other arguments as for `wprintf`. */ -void debug_printf( int level, wchar_t * format, ...) { - #ifdef DEBUG - if ( level & verbosity ) { - fwide( stderr, 1 ); - va_list(args); - va_start(args, format); - vfwprintf(stderr, format, args); - } - #endif +void debug_printf( int level, wchar_t *format, ... ) { +#ifdef DEBUG + if ( level & verbosity ) { + fwide( stderr, 1 ); + va_list( args ); + va_start( args, format ); + vfwprintf( stderr, format, args ); + } +#endif } /** @@ -80,8 +105,10 @@ void debug_printf( int level, wchar_t * format, ...) { void debug_print_object( struct cons_pointer pointer, int level ) { #ifdef DEBUG if ( level & verbosity ) { + URL_FILE *ustderr = file_to_url_file( stderr ); fwide( stderr, 1 ); - print( stderr, pointer ); + print( ustderr, pointer ); + free( ustderr ); } #endif } @@ -92,8 +119,10 @@ void debug_print_object( struct cons_pointer pointer, int level ) { void debug_dump_object( struct cons_pointer pointer, int level ) { #ifdef DEBUG if ( level & verbosity ) { - fwide( stderr, 1 ); - dump_object( stderr, pointer ); + URL_FILE *ustderr = file_to_url_file( stderr ); + fwide( stderr, 1 ); + dump_object( ustderr, pointer ); + free( ustderr ); } #endif } diff --git a/src/debug.h b/src/debug.h index 22f5591..babbaea 100644 --- a/src/debug.h +++ b/src/debug.h @@ -14,19 +14,21 @@ #define __debug_print_h #define DEBUG_ALLOC 1 -#define DEBUG_STACK 2 -#define DEBUG_ARITH 4 -#define DEBUG_EVAL 8 -#define DEBUG_LAMBDA 16 -#define DEBUG_BOOTSTRAP 32 -#define DEBUG_IO 64 +#define DEBUG_ARITH 2 +#define DEBUG_BIND 4 +#define DEBUG_BOOTSTRAP 8 +#define DEBUG_EVAL 16 +#define DEBUG_IO 32 +#define DEBUG_LAMBDA 64 #define DEBUG_REPL 128 +#define DEBUG_STACK 256 extern int verbosity; void debug_print( wchar_t *message, int level ); +void debug_print_128bit( __int128_t n, int level ); void debug_println( int level ); -void debug_printf( int level, wchar_t * format, ...); +void debug_printf( int level, wchar_t *format, ... ); void debug_print_object( struct cons_pointer pointer, int level ); void debug_dump_object( struct cons_pointer pointer, int level ); diff --git a/src/init.c b/src/init.c index d81aa00..676964f 100644 --- a/src/init.c +++ b/src/init.c @@ -9,57 +9,138 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#include #include #include #include #include #include +/* libcurl, used for io */ +#include + #include "version.h" -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "memory/stack.h" #include "debug.h" -#include "intern.h" -#include "lispops.h" -#include "peano.h" -#include "print.h" +#include "memory/hashmap.h" +#include "ops/intern.h" +#include "io/io.h" +#include "ops/lispops.h" +#include "ops/meta.h" +#include "arith/peano.h" +#include "io/print.h" #include "repl.h" +#include "io/fopen.h" +#include "time/psse_time.h" // extern char *optarg; /* defined in unistd.h */ +/** + * Bind this compiled `executable` function, as a Lisp function, to + * this name in the `oblist`. + * \todo where a function is not compiled from source, we could cache + * the name on the source pointer. Would make stack frames potentially + * more readable and aid debugging generally. + */ void bind_function( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { - deep_bind( c_string_to_lisp_symbol( name ), - make_function( NIL, executable ) ); + struct cons_pointer n = c_string_to_lisp_symbol( name ); + struct cons_pointer meta = + make_cons( make_cons( c_string_to_lisp_keyword( L"primitive" ), TRUE ), + make_cons( make_cons( c_string_to_lisp_keyword( L"name" ), + n ), + NIL ) ); + + deep_bind( n, make_function( meta, executable ) ); } +/** + * Bind this compiled `executable` function, as a Lisp special form, to + * this `name` in the `oblist`. + */ void bind_special( wchar_t *name, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ) { - deep_bind( c_string_to_lisp_symbol( name ), - make_special( NIL, executable ) ); + struct cons_pointer n = c_string_to_lisp_symbol( name ); + struct cons_pointer meta = + make_cons( make_cons( c_string_to_lisp_keyword( L"primitive" ), TRUE ), + make_cons( make_cons( c_string_to_lisp_keyword( L"name" ), + n ), + NIL ) ); + + deep_bind( n, make_special( meta, executable ) ); } +/** + * Bind this `value` to this `name` in the `oblist`. + */ +void bind_value( wchar_t *name, struct cons_pointer value ) { + struct cons_pointer n = c_string_to_lisp_symbol( name ); + inc_ref( n ); + + deep_bind( n, value ); + + dec_ref( n ); +} + +void print_banner( ) { + fwprintf( stdout, L"Post-Scarcity Software Environment version %s\n\n", + VERSION ); +} + +/** + * Print command line options to this `stream`. + * + * @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" ); +} + +/** + * main entry point; parse command line arguments, initialise the environment, + * and enter the read-eval-print loop. + */ int main( int argc, char *argv[] ) { - /* - * attempt to set wide character acceptance on all streams - */ - fwide( stdin, 1 ); - fwide( stdout, 1 ); - fwide( stderr, 1 ); int option; bool dump_at_end = false; bool show_prompt = false; - while ( ( option = getopt( argc, argv, "cpdv:" ) ) != -1 ) { + setlocale( LC_ALL, "" ); + if ( io_init( ) != 0 ) { + fputs( "Failed to initialise I/O subsystem\n", stderr ); + exit( 1 ); + } + + while ( ( option = getopt( argc, argv, "phdv:" ) ) != -1 ) { switch ( option ) { - case 'c': - print_use_colours = true; - break; case 'd': dump_at_end = true; break; + case 'h': + print_banner( ); + print_options( stdout ); + exit( 0 ); + break; case 'p': show_prompt = true; break; @@ -68,14 +149,14 @@ int main( int argc, char *argv[] ) { break; default: fwprintf( stderr, L"Unexpected option %c\n", option ); + print_options( stderr ); + exit( 1 ); break; } } if ( show_prompt ) { - fwprintf( stdout, - L"Post scarcity software environment version %s\n\n", - VERSION ); + print_banner( ); } debug_print( L"About to initialise cons pages\n", DEBUG_BOOTSTRAP ); @@ -84,60 +165,132 @@ 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) */ - deep_bind( c_string_to_lisp_symbol( L"nil" ), NIL ); - deep_bind( c_string_to_lisp_symbol( L"t" ), TRUE ); + bind_value( L"nil", NIL ); + bind_value( L"t", TRUE ); + /* + * standard input, output, error and sink streams + * attempt to set wide character acceptance on all streams + */ + URL_FILE *sink = url_fopen( "/dev/null", "w" ); + fwide( stdin, 1 ); + fwide( stdout, 1 ); + fwide( stderr, 1 ); + fwide( sink->handle.file, 1 ); + bind_value( L"*in*", make_read_stream( file_to_url_file( stdin ), + make_cons( make_cons + ( c_string_to_lisp_keyword + ( L"url" ), + c_string_to_lisp_string + ( L"system:standard input" ) ), + NIL ) ) ); + bind_value( L"*out*", + make_write_stream( file_to_url_file( stdout ), + make_cons( make_cons + ( c_string_to_lisp_keyword + ( L"url" ), + c_string_to_lisp_string + ( L"system:standard output]" ) ), + NIL ) ) ); + bind_value( L"*log*", make_write_stream( file_to_url_file( stderr ), + make_cons( make_cons + ( c_string_to_lisp_keyword + ( L"url" ), + c_string_to_lisp_string + ( L"system:standard log" ) ), + NIL ) ) ); + bind_value( L"*sink*", make_write_stream( sink, + make_cons( make_cons + ( c_string_to_lisp_keyword + ( L"url" ), + c_string_to_lisp_string + ( L"system:standard sink" ) ), + NIL ) ) ); + /* + * the default prompt + */ + bind_value( L"*prompt*", + show_prompt ? c_string_to_lisp_symbol( L":: " ) : NIL ); /* * primitive function operations */ - bind_function( L"add", &lisp_add ); - bind_function( L"apply", &lisp_apply ); - bind_function( L"assoc", &lisp_assoc ); - bind_function( L"car", &lisp_car ); - bind_function( L"cdr", &lisp_cdr ); - bind_function( L"cons", &lisp_cons ); - bind_function( L"divide", &lisp_divide ); - bind_function( L"eq", &lisp_eq ); - bind_function( L"equal", &lisp_equal ); - bind_function( L"eval", &lisp_eval ); - bind_function( L"exception", &lisp_exception ); - bind_function( L"multiply", &lisp_multiply ); - bind_function( L"read", &lisp_read ); - bind_function( L"oblist", &lisp_oblist ); - bind_function( L"print", &lisp_print ); - bind_function( L"progn", &lisp_progn ); - bind_function( L"reverse", &lisp_reverse ); - bind_function( L"set", &lisp_set ); - bind_function( L"subtract", &lisp_subtract ); - bind_function( L"throw", &lisp_exception ); - bind_function( L"type", &lisp_type ); - - bind_function( L"+", &lisp_add ); - bind_function( L"*", &lisp_multiply ); - bind_function( L"-", &lisp_subtract ); - bind_function( L"/", &lisp_divide ); - bind_function( L"=", &lisp_equal ); - + bind_function( L"absolute", &lisp_absolute ); + bind_function( L"add", &lisp_add ); + bind_function( L"append", &lisp_append ); + bind_function( L"apply", &lisp_apply ); + bind_function( L"assoc", &lisp_assoc ); + bind_function( L"car", &lisp_car ); + bind_function( L"cdr", &lisp_cdr ); + bind_function( L"close", &lisp_close ); + bind_function( L"cons", &lisp_cons ); + bind_function( L"divide", &lisp_divide ); + bind_function( L"eq", &lisp_eq ); + bind_function( L"equal", &lisp_equal ); + bind_function( L"eval", &lisp_eval ); + bind_function( L"exception", &lisp_exception ); + bind_function( L"get-hash", &lisp_get_hash ); + bind_function( L"hashmap", lisp_make_hashmap ); + bind_function( L"inspect", &lisp_inspect ); + bind_function( L"keys", &lisp_keys ); + bind_function( L"list", &lisp_list ); + bind_function( L"mapcar", &lisp_mapcar ); + bind_function( L"meta", &lisp_metadata ); + bind_function( L"metadata", &lisp_metadata ); + bind_function( L"multiply", &lisp_multiply ); + bind_function( L"negative?", &lisp_is_negative ); + bind_function( L"oblist", &lisp_oblist ); + bind_function( L"open", &lisp_open ); + bind_function( L"print", &lisp_print ); + bind_function( L"put!", lisp_hashmap_put ); + bind_function( L"put-all!", &lisp_hashmap_put_all ); + bind_function( L"read", &lisp_read ); + bind_function( L"read-char", &lisp_read_char ); + bind_function( L"repl", &lisp_repl ); + bind_function( L"reverse", &lisp_reverse ); + bind_function( L"set", &lisp_set ); + bind_function( L"slurp", &lisp_slurp ); + bind_function( L"source", &lisp_source ); + bind_function( L"subtract", &lisp_subtract ); + bind_function( L"throw", &lisp_exception ); + bind_function( L"time", &lisp_time ); + bind_function( L"type", &lisp_type ); + bind_function( L"+", &lisp_add ); + bind_function( L"*", &lisp_multiply ); + bind_function( L"-", &lisp_subtract ); + bind_function( L"/", &lisp_divide ); + bind_function( L"=", &lisp_equal ); /* * primitive special forms */ - bind_special( L"cond", &lisp_cond ); - bind_special( L"lambda", &lisp_lambda ); - // bind_special( L"λ", &lisp_lambda ); - bind_special( L"nlambda", &lisp_nlambda ); - // bind_special( L"nλ", &lisp_nlambda ); - bind_special( L"progn", &lisp_progn ); - bind_special( L"quote", &lisp_quote ); - bind_special( L"set!", &lisp_set_shriek ); + 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( stdin, stdout, stderr, show_prompt ); + repl( show_prompt ); + debug_print( L"Freeing oblist\n", DEBUG_BOOTSTRAP ); + dec_ref( oblist ); + debug_dump_object( oblist, DEBUG_BOOTSTRAP ); if ( dump_at_end ) { - dump_pages( stdout ); + dump_pages( file_to_url_file( stdout ) ); } + summarise_allocation( ); + curl_global_cleanup( ); return ( 0 ); } diff --git a/src/io/fopen.c b/src/io/fopen.c new file mode 100644 index 0000000..e4fafdd --- /dev/null +++ b/src/io/fopen.c @@ -0,0 +1,526 @@ +/* + * fopen.c + * + * adapted from https://curl.haxx.se/libcurl/c/fopen.html. + * + * Modifications to read/write wide character streams by + * Simon Brooke. + * + * NOTE THAT: for my purposes, I'm only interested in wide characters, + * and I always read them one character at a time. + * + * Copyright (c) 2003, 2017 Simtec Electronics + * Some portions (c) 2019 Simon Brooke + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. The name of the author may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * This example requires libcurl 7.9.7 or later. + */ + +#include +#include +#ifndef WIN32 +#include +#endif +#include +#include + +#include + +#include "io/fopen.h" +#ifdef FOPEN_STANDALONE +CURLSH *io_share; +#else +#include "memory/consspaceobject.h" +#include "io/io.h" +#include "utils.h" +#endif + + +/* exported functions */ +URL_FILE *url_fopen( const char *url, const char *operation ); +int url_fclose( URL_FILE * file ); +int url_feof( URL_FILE * file ); +size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ); +char *url_fgets( char *ptr, size_t size, URL_FILE * file ); +void url_rewind( URL_FILE * file ); + +/* we use a global one for convenience */ +static CURLM *multi_handle; + +/* curl calls this routine to get more data */ +static size_t write_callback( char *buffer, + size_t size, size_t nitems, void *userp ) { + char *newbuff; + size_t rembuff; + + URL_FILE *url = ( URL_FILE * ) userp; + size *= nitems; + + rembuff = url->buffer_len - url->buffer_pos; /* remaining space in buffer */ + + if ( size > rembuff ) { + /* not enough space in buffer */ + newbuff = realloc( url->buffer, url->buffer_len + ( size - rembuff ) ); + if ( newbuff == NULL ) { + fprintf( stderr, "callback buffer grow failed\n" ); + size = rembuff; + } else { + /* realloc succeeded increase buffer size */ + url->buffer_len += size - rembuff; + url->buffer = newbuff; + } + } + + memcpy( &url->buffer[url->buffer_pos], buffer, size ); + url->buffer_pos += size; + + return size; +} + +/* use to attempt to fill the read buffer up to requested number of bytes */ +static int fill_buffer( URL_FILE * file, size_t want ) { + fd_set fdread; + fd_set fdwrite; + fd_set fdexcep; + struct timeval timeout; + int rc; + CURLMcode mc; /* curl_multi_fdset() return code */ + + /* only attempt to fill buffer if transactions still running and buffer + * doesn't exceed required size already + */ + if ( ( !file->still_running ) || ( file->buffer_pos > want ) ) + return 0; + + /* attempt to fill buffer */ + do { + int maxfd = -1; + long curl_timeo = -1; + + FD_ZERO( &fdread ); + FD_ZERO( &fdwrite ); + FD_ZERO( &fdexcep ); + + /* set a suitable timeout to fail on */ + timeout.tv_sec = 60; /* 1 minute */ + timeout.tv_usec = 0; + + curl_multi_timeout( multi_handle, &curl_timeo ); + if ( curl_timeo >= 0 ) { + timeout.tv_sec = curl_timeo / 1000; + if ( timeout.tv_sec > 1 ) + timeout.tv_sec = 1; + else + timeout.tv_usec = ( curl_timeo % 1000 ) * 1000; + } + + /* get file descriptors from the transfers */ + mc = curl_multi_fdset( multi_handle, &fdread, &fdwrite, &fdexcep, + &maxfd ); + + if ( mc != CURLM_OK ) { + fprintf( stderr, "curl_multi_fdset() failed, code %d.\n", mc ); + break; + } + + /* On success the value of maxfd is guaranteed to be >= -1. We call + select(maxfd + 1, ...); specially in case of (maxfd == -1) there are + no fds ready yet so we call select(0, ...) --or Sleep() on Windows-- + to sleep 100ms, which is the minimum suggested value in the + curl_multi_fdset() doc. */ + + if ( maxfd == -1 ) { +#ifdef _WIN32 + Sleep( 100 ); + rc = 0; +#else + /* Portable sleep for platforms other than Windows. */ + struct timeval wait = { 0, 100 * 1000 }; /* 100ms */ + rc = select( 0, NULL, NULL, NULL, &wait ); +#endif + } else { + /* Note that on some platforms 'timeout' may be modified by select(). + If you need access to the original value save a copy beforehand. */ + rc = select( maxfd + 1, &fdread, &fdwrite, &fdexcep, &timeout ); + } + + switch ( rc ) { + case -1: + /* select error */ + break; + + case 0: + default: + /* timeout or readable/writable sockets */ + curl_multi_perform( multi_handle, &file->still_running ); + break; + } + } while ( file->still_running && ( file->buffer_pos < want ) ); + return 1; +} + +/* use to remove want bytes from the front of a files buffer */ +static int use_buffer( URL_FILE * file, size_t want ) { + /* sort out buffer */ + if ( ( file->buffer_pos - want ) <= 0 ) { + /* ditch buffer - write will recreate */ + free( file->buffer ); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + } else { + /* move rest down make it available for later */ + memmove( file->buffer, + &file->buffer[want], ( file->buffer_pos - want ) ); + + file->buffer_pos -= want; + } + return 0; +} + +URL_FILE *url_fopen( const char *url, const char *operation ) { + /* this code could check for URLs or types in the 'url' and + basically use the real fopen() for standard files */ + + URL_FILE *file; + ( void ) operation; + + file = calloc( 1, sizeof( URL_FILE ) ); + if ( !file ) + return NULL; + + file->handle.file = fopen( url, operation ); + if ( file->handle.file ) { + file->type = CFTYPE_FILE; /* marked as file */ + } else if ( index_of( ':', url ) > -1 ) { + file->type = CFTYPE_CURL; /* marked as URL */ + file->handle.curl = curl_easy_init( ); + + curl_easy_setopt( file->handle.curl, CURLOPT_URL, url ); + curl_easy_setopt( file->handle.curl, CURLOPT_WRITEDATA, file ); + curl_easy_setopt( file->handle.curl, CURLOPT_VERBOSE, 0L ); + curl_easy_setopt( file->handle.curl, CURLOPT_WRITEFUNCTION, + write_callback ); + /* use the share object */ + curl_easy_setopt( file->handle.curl, CURLOPT_SHARE, io_share ); + + + if ( !multi_handle ) + multi_handle = curl_multi_init( ); + + curl_multi_add_handle( multi_handle, file->handle.curl ); + + /* lets start the fetch */ + curl_multi_perform( multi_handle, &file->still_running ); + + if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) { + /* if still_running is 0 now, we should return NULL */ + + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); + + /* cleanup */ + curl_easy_cleanup( file->handle.curl ); + + free( file ); + + file = NULL; + } + } else { + file->type = CFTYPE_NONE; + /* not a file, and doesn't look like a URL. */ + } + + return file; +} + +int url_fclose( URL_FILE * file ) { + int ret = 0; /* default is good return */ + + switch ( file->type ) { + case CFTYPE_FILE: + ret = fclose( file->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL: + /* make sure the easy handle is not in the multi handle anymore */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); + + /* cleanup */ + curl_easy_cleanup( file->handle.curl ); + break; + + default: /* unknown or supported type - oh dear */ + ret = EOF; + errno = EBADF; + break; + } + + free( file->buffer ); /* free any allocated buffer space */ + free( file ); + + return ret; +} + +int url_feof( URL_FILE * file ) { + int ret = 0; + + switch ( file->type ) { + case CFTYPE_FILE: + ret = feof( file->handle.file ); + break; + + case CFTYPE_CURL: + if ( ( file->buffer_pos == 0 ) && ( !file->still_running ) ) + ret = 1; + break; + + default: /* unknown or supported type - oh dear */ + ret = -1; + errno = EBADF; + break; + } + return ret; +} + +size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ) { + size_t want; + + switch ( file->type ) { + case CFTYPE_FILE: + want = fread( ptr, size, nmemb, file->handle.file ); + break; + + case CFTYPE_CURL: + want = nmemb * size; + + fill_buffer( file, want ); + + /* check if there's data in the buffer - if not fill_buffer() + * either errored or EOF */ + if ( !file->buffer_pos ) + return 0; + + /* ensure only available data is considered */ + if ( file->buffer_pos < want ) + want = file->buffer_pos; + + /* xfer data to caller */ + memcpy( ptr, file->buffer, want ); + + use_buffer( file, want ); + + want = want / size; /* number of items */ + break; + + default: /* unknown or supported type - oh dear */ + want = 0; + errno = EBADF; + break; + + } + return want; +} + +char *url_fgets( char *ptr, size_t size, URL_FILE * file ) { + size_t want = size - 1; /* always need to leave room for zero termination */ + size_t loop; + + switch ( file->type ) { + case CFTYPE_FILE: + ptr = fgets( ptr, ( int ) size, file->handle.file ); + break; + + case CFTYPE_CURL: + fill_buffer( file, want ); + + /* check if there's data in the buffer - if not fill either errored or + * EOF */ + if ( !file->buffer_pos ) + return NULL; + + /* ensure only available data is considered */ + if ( file->buffer_pos < want ) + want = file->buffer_pos; + + /*buffer contains data */ + /* look for newline or eof */ + for ( loop = 0; loop < want; loop++ ) { + if ( file->buffer[loop] == '\n' ) { + want = loop + 1; /* include newline */ + break; + } + } + + /* xfer data to caller */ + memcpy( ptr, file->buffer, want ); + ptr[want] = 0; /* always null terminate */ + + use_buffer( file, want ); + + break; + + default: /* unknown or supported type - oh dear */ + ptr = NULL; + errno = EBADF; + break; + } + + return ptr; /*success */ +} + +void url_rewind( URL_FILE * file ) { + switch ( file->type ) { + case CFTYPE_FILE: + rewind( file->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL: + /* halt transaction */ + curl_multi_remove_handle( multi_handle, file->handle.curl ); + + /* restart */ + curl_multi_add_handle( multi_handle, file->handle.curl ); + + /* ditch buffer - write will recreate - resets stream pos */ + free( file->buffer ); + file->buffer = NULL; + file->buffer_pos = 0; + file->buffer_len = 0; + + break; + + default: /* unknown or supported type - oh dear */ + break; + } +} + +#ifdef FOPEN_STANDALONE +#define FGETSFILE "fgets.test" +#define FREADFILE "fread.test" +#define REWINDFILE "rewind.test" + +/* Small main program to retrieve from a url using fgets and fread saving the + * output to two test files (note the fgets method will corrupt binary files if + * they contain 0 chars */ +int main( int argc, char *argv[] ) { + URL_FILE *handle; + FILE *outf; + + size_t nread; + char buffer[256]; + const char *url; + + CURL *curl; + CURLcode res; + + curl_global_init( CURL_GLOBAL_DEFAULT ); + + curl = curl_easy_init( ); + + + if ( argc < 2 ) + url = "http://192.168.7.3/testfile"; /* default to testurl */ + else + url = argv[1]; /* use passed url */ + + /* copy from url line by line with fgets */ + outf = fopen( FGETSFILE, "wb+" ); + if ( !outf ) { + perror( "couldn't open fgets output file\n" ); + return 1; + } + + handle = url_fopen( url, "r" ); + if ( !handle ) { + printf( "couldn't url_fopen() %s\n", url ); + fclose( outf ); + return 2; + } + + while ( !url_feof( handle ) ) { + url_fgets( buffer, sizeof( buffer ), handle ); + fwrite( buffer, 1, strlen( buffer ), outf ); + } + + url_fclose( handle ); + + fclose( outf ); + + + /* Copy from url with fread */ + outf = fopen( FREADFILE, "wb+" ); + if ( !outf ) { + perror( "couldn't open fread output file\n" ); + return 1; + } + + handle = url_fopen( "testfile", "r" ); + if ( !handle ) { + printf( "couldn't url_fopen() testfile\n" ); + fclose( outf ); + return 2; + } + + do { + nread = url_fread( buffer, 1, sizeof( buffer ), handle ); + fwrite( buffer, 1, nread, outf ); + } while ( nread ); + + url_fclose( handle ); + + fclose( outf ); + + + /* Test rewind */ + outf = fopen( REWINDFILE, "wb+" ); + if ( !outf ) { + perror( "couldn't open fread output file\n" ); + return 1; + } + + handle = url_fopen( "testfile", "r" ); + if ( !handle ) { + printf( "couldn't url_fopen() testfile\n" ); + fclose( outf ); + return 2; + } + + nread = url_fread( buffer, 1, sizeof( buffer ), handle ); + fwrite( buffer, 1, nread, outf ); + url_rewind( handle ); + + buffer[0] = '\n'; + fwrite( buffer, 1, 1, outf ); + + nread = url_fread( buffer, 1, sizeof( buffer ), handle ); + fwrite( buffer, 1, nread, outf ); + + url_fclose( handle ); + + fclose( outf ); + + return 0; /* all done */ +} +#endif diff --git a/src/io/fopen.h b/src/io/fopen.h new file mode 100644 index 0000000..5f87bd2 --- /dev/null +++ b/src/io/fopen.h @@ -0,0 +1,83 @@ +/* + * fopen.h + * + * adapted from https://curl.haxx.se/libcurl/c/fopen.html. + * + * + * Modifications to read/write wide character streams by + * Simon Brooke. + * + * NOTE THAT: for my purposes, I'm only interested in wide characters, + * and I always read them one character at a time. + * + * Copyright (c) 2003, 2017 Simtec Electronics + * Some portions (c) 2019 Simon Brooke + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. The name of the author may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * This example requires libcurl 7.9.7 or later. + */ + +#ifndef __fopen_h +#define __fopen_h +#include +/* + * wide characters + */ +#include +#include + +#define url_fwprintf(f, ...) ((f->type = CFTYPE_FILE) ? fwprintf( f->handle.file, __VA_ARGS__) : -1) +#define url_fputws(ws, f) ((f->type = CFTYPE_FILE) ? fputws(ws, f->handle.file) : 0) +#define url_fputwc(wc, f) ((f->type = CFTYPE_FILE) ? fputwc(wc, f->handle.file) : 0) + +enum fcurl_type_e { + CFTYPE_NONE = 0, + CFTYPE_FILE = 1, + CFTYPE_CURL = 2 +}; + +struct fcurl_data { + enum fcurl_type_e type; /* type of handle */ + union { + CURL *curl; + FILE *file; + } handle; /* handle */ + + char *buffer; /* buffer to store cached data */ + size_t buffer_len; /* currently allocated buffer's length */ + size_t buffer_pos; /* cursor into in buffer */ + int still_running; /* Is background url fetch still in progress */ +}; + +typedef struct fcurl_data URL_FILE; + +/* exported functions */ +URL_FILE *url_fopen( const char *url, const char *operation ); +int url_fclose( URL_FILE * file ); +int url_feof( URL_FILE * file ); +size_t url_fread( void *ptr, size_t size, size_t nmemb, URL_FILE * file ); +char *url_fgets( char *ptr, size_t size, URL_FILE * file ); +void url_rewind( URL_FILE * file ); + +#endif diff --git a/src/io/io.c b/src/io/io.c new file mode 100644 index 0000000..d01f788 --- /dev/null +++ b/src/io/io.c @@ -0,0 +1,549 @@ +/* + * io.c + * + * Communication between PSSE and the outside world, via libcurl. NOTE + * that this file destructively changes metadata on URL connections, + * because the metadata is not available until the stream has been read + * from. It would be better to find a workaround! + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#include + +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "debug.h" +#include "io/fopen.h" +#include "arith/integer.h" +#include "ops/intern.h" +#include "ops/lispops.h" +#include "utils.h" + +/** + * The sharing hub for all connections. TODO: Ultimately this probably doesn't + * work for a multi-user environment and we will need one sharing hub for each + * user, or else we will need to not share at least cookies and ssl sessions. + */ +CURLSH *io_share; + +/** + * Allow a one-character unget facility. This may not be enough - we may need + * to allocate a buffer. + */ +wint_t ungotten = 0; + +/** + * Initialise the I/O subsystem. + * + * @return 0 on success; any other value means failure. + */ +int io_init( ) { + int result = curl_global_init( CURL_GLOBAL_SSL ); + + io_share = curl_share_init( ); + + if ( result == 0 ) { + curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_CONNECT ); + curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_COOKIE ); + curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_DNS ); + curl_share_setopt( io_share, CURLSHOPT_SHARE, + CURL_LOCK_DATA_SSL_SESSION ); + curl_share_setopt( io_share, CURLSHOPT_SHARE, CURL_LOCK_DATA_PSL ); + } + + return result; +} + +/** + * Convert this lisp string-like-thing (also works for symbols, and, later + * keywords) into a UTF-8 string. NOTE that the returned value has been + * malloced and must be freed. TODO: candidate to moving into a utilities + * file. + * + * @param s the lisp string or symbol; + * @return the c string. + */ +char *lisp_string_to_c_string( struct cons_pointer s ) { + char *result = NULL; + + if ( stringp( s ) || symbolp( s ) ) { + int len = 0; + + for ( struct cons_pointer c = s; !nilp( c ); + c = pointer2cell( c ).payload.string.cdr ) { + len++; + } + + wchar_t *buffer = calloc( len + 1, sizeof( wchar_t ) ); + /* worst case, one wide char = four utf bytes */ + result = calloc( ( len * 4 ) + 1, sizeof( char ) ); + + int i = 0; + for ( struct cons_pointer c = s; !nilp( c ); + c = pointer2cell( c ).payload.string.cdr ) { + buffer[i++] = pointer2cell( c ).payload.string.character; + } + + wcstombs( result, buffer, len ); + free( buffer ); + } + + debug_print( L"lisp_string_to_c_string( ", DEBUG_IO ); + debug_print_object( s, DEBUG_IO ); + debug_printf( DEBUG_IO, L") => '%s'\n", result ); + + return result; +} + + +/** + * given this file handle f, return a new url_file handle wrapping it. + * + * @param f the file to be wrapped; + * @return the new handle, or null if no such handle could be allocated. + */ +URL_FILE *file_to_url_file( FILE * f ) { + URL_FILE *result = ( URL_FILE * ) malloc( sizeof( URL_FILE ) ); + + if ( result != NULL ) { + result->type = CFTYPE_FILE, result->handle.file = f; + } + + return result; +} + + +/** + * get one wide character from the buffer. + * + * @param file the stream to read from; + * @return the next wide character on the stream, or zero if no more. + */ +wint_t url_fgetwc( URL_FILE * input ) { + wint_t result = -1; + + if ( ungotten != 0 ) { + /* TODO: not thread safe */ + result = ungotten; + ungotten = 0; + } else { + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = fgetwc( input->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL:{ + char *cbuff = + calloc( sizeof( wchar_t ) + 2, sizeof( char ) ); + wchar_t *wbuff = calloc( 2, sizeof( wchar_t ) ); + + size_t count = 0; + + debug_print( L"url_fgetwc: about to call url_fgets\n", + DEBUG_IO ); + url_fgets( cbuff, 2, input ); + debug_print( L"url_fgetwc: back from url_fgets\n", + DEBUG_IO ); + int c = ( int ) cbuff[0]; + // 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 ); + /* The value of each individual byte indicates its UTF-8 function, as follows: + * + * 00 to 7F hex (0 to 127): first and only byte of a sequence. + * 80 to BF hex (128 to 191): continuing byte in a multi-byte sequence. + * C2 to DF hex (194 to 223): first byte of a two-byte sequence. + * E0 to EF hex (224 to 239): first byte of a three-byte sequence. + * F0 to FF hex (240 to 255): first byte of a four-byte sequence. + */ + if ( c <= 0xf7 ) { + count = 1; + } else if ( c >= 0xc2 && c <= 0xdf ) { + count = 2; + } else if ( c >= 0xe0 && c <= 0xef ) { + count = 3; + } else if ( c >= 0xf0 && c <= 0xff ) { + count = 4; + } + + if ( count > 1 ) { + url_fgets( ( char * ) &cbuff[1], count, input ); + } + mbstowcs( wbuff, cbuff, 2 ); //(char *)(&input->buffer[input->buffer_pos]), 1 ); + result = wbuff[0]; + + free( wbuff ); + free( cbuff ); + } + break; + case CFTYPE_NONE: + break; + } + } + + debug_printf( DEBUG_IO, L"url_fgetwc returning %d (%C)\n", result, + result ); + return result; +} + +wint_t url_ungetwc( wint_t wc, URL_FILE * input ) { + wint_t result = -1; + + switch ( input->type ) { + case CFTYPE_FILE: + fwide( input->handle.file, 1 ); /* wide characters */ + result = ungetwc( wc, input->handle.file ); /* passthrough */ + break; + + case CFTYPE_CURL:{ + ungotten = wc; + break; + case CFTYPE_NONE: + break; + } + } + + return result; +} + + +/** + * Function, sort-of: close the file indicated by my first arg, and return + * nil. If the first arg is not a stream, does nothing. All other args are + * ignored. + * + * * (close stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return T if the stream was successfully closed, else NIL. + */ +struct cons_pointer +lisp_close( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( readp( frame->arg[0] ) || writep( frame->arg[0] ) ) { + if ( url_fclose( pointer2cell( frame->arg[0] ).payload.stream.stream ) + == 0 ) { + result = TRUE; + } + } + + return result; +} + +struct cons_pointer add_meta_integer( struct cons_pointer meta, wchar_t *key, + long int value ) { + return + make_cons( make_cons + ( c_string_to_lisp_keyword( key ), + make_integer( value, NIL ) ), meta ); +} + +struct cons_pointer add_meta_string( struct cons_pointer meta, wchar_t *key, + char *value ) { + value = trim( value ); + wchar_t buffer[strlen( value ) + 1]; + mbstowcs( buffer, value, strlen( value ) + 1 ); + + return make_cons( make_cons( c_string_to_lisp_keyword( key ), + c_string_to_lisp_string( buffer ) ), meta ); +} + +struct cons_pointer add_meta_time( struct cons_pointer meta, wchar_t *key, + time_t * value ) { + /* I don't yet have a concept of a date-time object, which is a + * bit of an oversight! */ + char datestring[256]; + + strftime( datestring, + sizeof( datestring ), + nl_langinfo( D_T_FMT ), localtime( value ) ); + + return add_meta_string( meta, key, datestring ); +} + +/** + * Callback to assemble metadata for a URL stream. This is naughty because + * it modifies data, but it's really the only way to create metadata. + */ +static size_t write_meta_callback( char *string, size_t size, size_t nmemb, + struct cons_pointer stream ) { + struct cons_space_object *cell = &pointer2cell( stream ); + + /* make a copy of the string that we can destructively change */ + char *s = calloc( strlen( string ), sizeof( char ) ); + + strcpy( s, string ); + + if ( strncmp( &cell->tag.bytes[0], READTAG, 4 ) || + strncmp( &cell->tag.bytes[0], WRITETAG, 4 ) ) { + int offset = index_of( ':', s ); + + if ( offset != -1 ) { + s[offset] = ( char ) 0; + char *name = trim( s ); + char *value = trim( &s[++offset] ); + wchar_t wname[strlen( name )]; + + mbstowcs( wname, name, strlen( name ) + 1 ); + + cell->payload.stream.meta = + add_meta_string( cell->payload.stream.meta, wname, value ); + + debug_printf( DEBUG_IO, + L"write_meta_callback: added header '%s': value '%s'\n", + name, value ); + } else if ( strncmp( "HTTP", s, 4 ) == 0 ) { + int offset = index_of( ' ', s ); + char *value = trim( &s[offset] ); + + cell->payload.stream.meta = + add_meta_integer( add_meta_string + ( cell->payload.stream.meta, L"status", + value ), L"status-code", strtol( value, + NULL, + 10 ) ); + + debug_printf( DEBUG_IO, + L"write_meta_callback: added header 'status': value '%s'\n", + value ); + } else { + debug_printf( DEBUG_IO, + L"write_meta_callback: header passed with no colon: '%s'\n", + s ); + } + } else { + debug_print + ( L"Pointer passed to write_meta_callback did not point to a stream: ", + DEBUG_IO ); + debug_dump_object( stream, DEBUG_IO ); + } + + free( s ); + return strlen( string ); +} + +void collect_meta( struct cons_pointer stream, char *url ) { + struct cons_space_object *cell = &pointer2cell( stream ); + URL_FILE *s = pointer2cell( stream ).payload.stream.stream; + struct cons_pointer meta = + add_meta_string( cell->payload.stream.meta, L"url", url ); + struct stat statbuf; + int result = stat( url, &statbuf ); + struct passwd *pwd; + struct group *grp; + + switch ( s->type ) { + case CFTYPE_NONE: + break; + case CFTYPE_FILE: + if ( result == 0 ) { + if ( ( pwd = getpwuid( statbuf.st_uid ) ) != NULL ) { + meta = add_meta_string( meta, L"owner", pwd->pw_name ); + } else { + meta = add_meta_integer( meta, L"owner", statbuf.st_uid ); + } + + if ( ( grp = getgrgid( statbuf.st_gid ) ) != NULL ) { + meta = add_meta_string( meta, L"group", grp->gr_name ); + } else { + meta = add_meta_integer( meta, L"group", statbuf.st_gid ); + } + + meta = + add_meta_integer( meta, L"size", + ( intmax_t ) statbuf.st_size ); + + meta = add_meta_time( meta, L"modified", &statbuf.st_mtime ); + } + break; + case CFTYPE_CURL: + curl_easy_setopt( s->handle.curl, CURLOPT_VERBOSE, 1L ); + curl_easy_setopt( s->handle.curl, CURLOPT_HEADERFUNCTION, + write_meta_callback ); + curl_easy_setopt( s->handle.curl, CURLOPT_HEADERDATA, stream ); + break; + } + + /* this is destructive change before the cell is released into the + * 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; + * if a second argument is present and is non-nil, open it for reading. At + * present, further arguments are ignored and there is no mechanism to open + * to append, or error if the URL is faulty or indicates an unavailable + * resource. + * + * * (read-char stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else NIL. + */ +struct cons_pointer +lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( stringp( frame->arg[0] ) ) { + char *url = lisp_string_to_c_string( frame->arg[0] ); + + if ( nilp( frame->arg[1] ) ) { + 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 ); + + switch ( stream->type ) { + case CFTYPE_NONE: + 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 ); + } + break; + case CFTYPE_CURL: + /* can't tell whether a URL is bad without reading it */ + break; + } + + result = make_read_stream( stream, NIL ); + } else { + // TODO: anything more complex is a problem for another day. + URL_FILE *stream = url_fopen( url, "w" ); + result = make_write_stream( stream, NIL ); + } + + if ( pointer2cell( result ).payload.stream.stream == NULL ) { + result = NIL; + } else { + collect_meta( result, url ); + } + + free( url ); + } + + return result; +} + +/** + * Function: return the next character from the stream indicated by arg 0; + * further arguments are ignored. + * + * * (read-char stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else NIL. + */ +struct cons_pointer +lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( readp( frame->arg[0] ) ) { + result = + make_string( url_fgetwc + ( pointer2cell( frame->arg[0] ).payload.stream. + stream ), NIL ); + } + + return result; +} + +/** + * Function: return a string representing all characters from the stream + * indicated by arg 0; further arguments are ignored. + * + * * (slurp stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return a string of one character, namely the next available character + * on my stream, if any, else NIL. + */ +struct cons_pointer +lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + + if ( readp( frame->arg[0] ) ) { + URL_FILE *stream = pointer2cell( frame->arg[0] ).payload.stream.stream; + struct cons_pointer cursor = make_string( url_fgetwc( stream ), NIL ); + result = cursor; + + for ( wint_t c = url_fgetwc( stream ); !url_feof( stream ) && c != 0; + c = url_fgetwc( stream ) ) { + debug_print( L"slurp: cursor is: ", DEBUG_IO ); + debug_dump_object( cursor, DEBUG_IO ); + debug_print( L"; result is: ", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + debug_println( DEBUG_IO ); + + struct cons_space_object *cell = &pointer2cell( cursor ); + cursor = make_string( ( wchar_t ) c, NIL ); + cell->payload.string.cdr = cursor; + } + } + + return result; +} diff --git a/src/io/io.h b/src/io/io.h new file mode 100644 index 0000000..f350c13 --- /dev/null +++ b/src/io/io.h @@ -0,0 +1,40 @@ + +/* + * io.h + * + * Communication between PSSE and the outside world, via libcurl. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_io_h +#define __psse_io_h +#include +#include "consspaceobject.h" + +extern CURLSH *io_share; + +int io_init( ); + +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 ); +struct cons_pointer +lisp_open( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer +lisp_read_char( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); +struct cons_pointer +lisp_slurp( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env ); + + +#endif diff --git a/src/io/print.c b/src/io/print.c new file mode 100644 index 0000000..8f4b88e --- /dev/null +++ b/src/io/print.c @@ -0,0 +1,281 @@ +/* + * print.c + * + * First pass at a printer, for bootstrapping. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +#include +/* + * wide characters + */ +#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" + +/** + * print all the characters in the symbol or string indicated by `pointer` + * onto this `output`; if `pointer` does not indicate a string or symbol, + * don't print anything but just return. + */ +void print_string_contents( URL_FILE * output, struct cons_pointer pointer ) { + while ( stringp( pointer ) || symbolp( pointer ) || keywordp( pointer ) ) { + struct cons_space_object *cell = &pointer2cell( pointer ); + wchar_t c = cell->payload.string.character; + + if ( c != '\0' ) { + url_fputwc( c, output ); + } + pointer = cell->payload.string.cdr; + } +} + +/** + * print all the characters in the string indicated by `pointer` onto + * the stream at this `output`, prepending and appending double quote + * characters. + */ +void print_string( URL_FILE * output, struct cons_pointer pointer ) { + url_fputwc( btowc( '"' ), output ); + print_string_contents( output, pointer ); + url_fputwc( btowc( '"' ), output ); +} + +/** + * Print a single list cell (cons cell) indicated by `pointer` to the + * stream indicated by `output`. if `initial_space` is `true`, prepend + * a space character. + */ +void +print_list_contents( URL_FILE * output, struct cons_pointer pointer, + bool initial_space ) { + struct cons_space_object *cell = &pointer2cell( pointer ); + + switch ( cell->tag.value ) { + case CONSTV: + if ( initial_space ) { + url_fputwc( btowc( ' ' ), output ); + } + print( output, cell->payload.cons.car ); + + print_list_contents( output, cell->payload.cons.cdr, true ); + break; + case NILTV: + break; + default: + url_fwprintf( output, L" . " ); + print( output, pointer ); + } +} + +void print_list( URL_FILE * output, struct cons_pointer pointer ) { + url_fputws( L"(", output ); + print_list_contents( output, pointer, false ); + url_fputws( L")", output ); +} + +void print_map( URL_FILE * output, struct cons_pointer map ) { + if ( hashmapp( map ) ) { + struct vector_space_object *vso = pointer_to_vso( map ); + + url_fputwc( btowc( '{' ), output ); + + 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 ( !nilp( c_cdr( ks ) ) ) { + url_fputws( L", ", 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 ); + break; + // \todo: others. + default: + fwprintf( stderr, L"Unrecognised vector-space type '%d'\n", + vso->header.tag.value ); + } +} + +/** + * stolen from https://stackoverflow.com/questions/11656241/how-to-print-uint128-t-number-using-gcc + */ +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 *s = str + sizeof( str ) - 1; // start at the end + while ( n != 0 ) { + if ( s == str ) + return; // never happens + + *--s = "0123456789"[n % 10]; // save last digit + n /= 10; // drop it + } + url_fwprintf( output, L"%s", s ); + } +} + + +/** + * Print the cons-space object indicated by `pointer` to the stream indicated + * by `output`. + */ +struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ) { + struct cons_space_object cell = pointer2cell( pointer ); + char *buffer; + + /* + * Because tags have values as well as bytes, this if ... else if + * statement can ultimately be replaced by a switch, which will be neater. + */ + switch ( cell.tag.value ) { + case CONSTV: + print_list( output, pointer ); + break; + case EXCEPTIONTV: + url_fputws( L"\nException: ", output ); + dump_stack_trace( output, pointer ); + break; + case FUNCTIONTV: + url_fputws( L"', output ); + break; + case INTEGERTV:{ + struct cons_pointer s = integer_to_string( pointer, 10 ); + inc_ref( s ); + print_string_contents( output, s ); + dec_ref( s ); + } + break; + case KEYTV: + url_fputws( L":", output ); + 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: + print( output, cell.payload.ratio.dividend ); + url_fputws( L"/", output ); + print( output, cell.payload.ratio.divisor ); + break; + case READTV: + url_fwprintf( output, L"', output ); + break; + case REALTV: + /* \todo using the C heap is a bad plan because it will fragment. + * As soon as I have working vector space I'll use a special purpose + * vector space object */ + buffer = ( char * ) malloc( 24 ); + memset( buffer, 0, 24 ); + /* format it really long, then clear the trailing zeros */ + sprintf( buffer, "%-.23Lg", cell.payload.real.value ); + if ( strchr( buffer, '.' ) != NULL ) { + for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) { + buffer[i] = '\0'; + } + } + url_fwprintf( output, L"%s", buffer ); + free( buffer ); + break; + case STRINGTV: + print_string( output, pointer ); + break; + case SYMBOLTV: + print_string_contents( output, pointer ); + break; + case SPECIALTV: + url_fwprintf( output, L"', output ); + break; + case TIMETV: + url_fwprintf( output, L"', output ); + break; + case TRUETV: + url_fwprintf( output, L"t" ); + break; + case VECTORPOINTTV: + print_vso( output, pointer ); + break; + case WRITETV: + url_fwprintf( output, L"', output ); + break; + default: + fwprintf( stderr, + L"Error: Unrecognised tag value %d (%4.4s)\n", + cell.tag.value, &cell.tag.bytes[0] ); + break; + } + + return pointer; +} + +void println( URL_FILE * output ) { + url_fputws( L"\n", output ); +} diff --git a/src/ops/print.h b/src/io/print.h similarity index 71% rename from src/ops/print.h rename to src/io/print.h index 1399db4..006ef80 100644 --- a/src/ops/print.h +++ b/src/io/print.h @@ -14,7 +14,7 @@ #ifndef __print_h #define __print_h -struct cons_pointer print( FILE * output, struct cons_pointer pointer ); -extern int print_use_colours; +struct cons_pointer print( URL_FILE * output, struct cons_pointer pointer ); +void println( URL_FILE * output ); #endif diff --git a/src/io/read.c b/src/io/read.c new file mode 100644 index 0000000..df0735b --- /dev/null +++ b/src/io/read.c @@ -0,0 +1,551 @@ +/* + * read.c + * + * First pass at a reader, for bootstrapping. + * + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#include "memory/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" + +/* + * for the time being things which may be read are: + * * strings + * * numbers - either integer, ratio or real + * * lists + * * maps + * * keywords + * * atoms + */ + +struct cons_pointer read_number( struct stack_frame *frame, + struct cons_pointer frame_pointer, + URL_FILE * input, wint_t initial, + 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 read_string( URL_FILE * input, wint_t initial ); +struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, + wint_t initial ); + +/** + * quote reader macro in C (!) + */ +struct cons_pointer c_quote( struct cons_pointer arg ) { + return make_cons( c_string_to_lisp_symbol( L"quote" ), + 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 + * representation. + */ +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; + + wint_t c; + + for ( c = initial; + c == '\0' || iswblank( c ) || iswcntrl( c ); + c = url_fgetwc( input ) ); + + if ( url_feof( input ) ) { + result = + throw_exception( c_string_to_lisp_string + ( L"End of file while reading" ), frame_pointer ); + } else { + switch ( c ) { + case ';': + for ( c = url_fgetwc( input ); c != '\n'; + c = url_fgetwc( input ) ); + /* skip all characters from semi-colon to the end of the line */ + break; + case EOF: + result = throw_exception( c_string_to_lisp_string + ( L"End of input while reading" ), + frame_pointer ); + break; + case '\'': + result = + c_quote( read_continuation + ( frame, frame_pointer, env, input, + url_fgetwc( input ) ) ); + break; + case '(': + result = + read_list( frame, frame_pointer, env, input, + url_fgetwc( input ) ); + break; + case '{': + result = read_map( frame, frame_pointer, env, input, + url_fgetwc( input ) ); + break; + case '"': + result = read_string( input, url_fgetwc( input ) ); + break; + case '-':{ + wint_t next = url_fgetwc( input ); + url_ungetwc( next, input ); + if ( iswdigit( next ) ) { + result = + read_number( frame, frame_pointer, input, c, + false ); + } else { + result = read_symbol_or_key( input, SYMBOLTV, c ); + } + } + break; + case '.': + { + wint_t next = url_fgetwc( input ); + if ( iswdigit( next ) ) { + url_ungetwc( next, input ); + result = + read_number( frame, frame_pointer, input, c, + true ); + } else if ( iswblank( next ) ) { + /* dotted pair. \todo this isn't right, we + * 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 ); + } else { + read_symbol_or_key( input, SYMBOLTV, 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 ); + 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 ); + } else { + result = + throw_exception( make_cons( c_string_to_lisp_string + ( L"Unrecognised start of input character" ), + make_string( c, NIL ) ), + frame_pointer ); + } + break; + } + } + debug_print( L"read_continuation returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + + return result; +} + +/** + * read a number from this input stream, given this initial character. + * \todo Need to do a lot of inc_ref and dec_ref, to make sure the + * garbage is collected. + */ +struct cons_pointer read_number( struct stack_frame *frame, + struct cons_pointer frame_pointer, + URL_FILE * input, + wint_t initial, bool seen_period ) { + debug_print( L"entering read_number\n", DEBUG_IO ); + + struct cons_pointer result = make_integer( 0, NIL ); + /* \todo we really need to be getting `base` from a privileged Lisp name - + * and it should be the same privileged name we use when writing numbers */ + struct cons_pointer base = make_integer( 10, NIL ); + struct cons_pointer dividend = NIL; + int places_of_decimals = 0; + wint_t c; + bool neg = initial == btowc( '-' ); + + if ( neg ) { + initial = url_fgetwc( input ); + } + + debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, + initial ); + + for ( c = initial; iswdigit( c ) + || c == L'.' || c == L'/' || c == L','; c = url_fgetwc( input ) ) { + switch ( c ) { + case L'.': + if ( seen_period || !nilp( dividend ) ) { + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: too many periods" ), + frame_pointer ); + } else { + debug_print( L"read_number: decimal point seen\n", + DEBUG_IO ); + seen_period = true; + } + break; + case L'/': + if ( seen_period || !nilp( dividend ) ) { + return throw_exception( c_string_to_lisp_string + ( L"Malformed number: dividend of rational must be integer" ), + frame_pointer ); + } else { + debug_print( L"read_number: ratio slash seen\n", + DEBUG_IO ); + dividend = result; + + result = make_integer( 0, NIL ); + } + break; + case L',': + // silently ignore it. + break; + default: + result = add_integers( multiply_integers( result, base ), + make_integer( ( int ) c - ( int ) '0', + NIL ) ); + + debug_printf( DEBUG_IO, + L"read_number: added character %c, result now ", + c ); + debug_print_object( result, DEBUG_IO ); + debug_print( L"\n", DEBUG_IO ); + + if ( seen_period ) { + places_of_decimals++; + } + } + } + + /* + * push back the character read which was not a digit + */ + url_ungetwc( c, input ); + + if ( seen_period ) { + debug_print( L"read_number: converting result to real\n", DEBUG_IO ); + struct cons_pointer div = make_ratio( result, + make_integer( powl + ( to_long_double + ( base ), + places_of_decimals ), + NIL ) ); + inc_ref( div ); + + result = make_real( to_long_double( div ) ); + + dec_ref( div ); + } else if ( integerp( dividend ) ) { + debug_print( L"read_number: converting result to ratio\n", DEBUG_IO ); + result = make_ratio( dividend, result ); + } + + if ( neg ) { + debug_print( L"read_number: converting result to negative\n", + DEBUG_IO ); + + result = negative( result ); + } + + debug_print( L"read_number returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + + return result; +} + +/** + * Read a list from this input stream, which no longer contains the opening + * 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 result = NIL; + wint_t c; + + if ( initial != ')' ) { + debug_printf( DEBUG_IO, + L"read_list starting '%C' (%d)\n", initial, initial ); + struct cons_pointer car = + read_continuation( frame, frame_pointer, env, input, + initial ); + + /* skip whitespace */ + for ( c = url_fgetwc( input ); + iswblank( c ) || iswcntrl( c ); c = url_fgetwc( input ) ); + + 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 ) ) ) ); + } else { + result = + make_cons( car, + read_list( frame, frame_pointer, env, input, c ) ); + } + } else { + debug_print( L"End of list detected\n", DEBUG_IO ); + } + + 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 ); + wint_t c = initial; + + while ( c != L'}' ) { + struct cons_pointer key = + read_continuation( frame, frame_pointer, env, input, c ); + + /* skip whitespace */ + 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 ); + + /* skip commaa and whitespace at this point. */ + 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 ) ); + } + + // 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 + * not contain a double quote character (unless escaped), or one not + * so delimited in which case it may not contain whitespace (unless escaped) + * but may contain a double quote character (probably not a good idea!) + */ +struct cons_pointer read_string( URL_FILE * input, wint_t initial ) { + struct cons_pointer cdr = NIL; + struct cons_pointer result; + switch ( initial ) { + case '\0': + result = NIL; + break; + case '"': + /* making a string of the null character means we can have an empty + * string. Just returning NIL here would make an empty string + * impossible. */ + result = make_string( '\0', NIL ); + break; + default: + result = + make_string( initial, + read_string( input, url_fgetwc( input ) ) ); + break; + } + + return result; +} + +struct cons_pointer read_symbol_or_key( URL_FILE * input, uint32_t tag, + wint_t initial ) { + struct cons_pointer cdr = NIL; + struct cons_pointer result; + switch ( initial ) { + case '\0': + result = make_symbol_or_key( initial, NIL, tag ); + break; + case '"': + case '\'': + /* unwise to allow embedded quotation marks in symbols */ + case ')': + case ':': + case '/': + /* + * symbols and keywords may not include right-parenthesis, + * slashes or colons. + */ + result = NIL; + /* + * push back the character read + */ + url_ungetwc( initial, input ); + break; + default: + if ( iswprint( initial ) + && !iswblank( initial ) ) { + result = + make_symbol_or_key( initial, + read_symbol_or_key( input, + tag, + url_fgetwc + ( input ) ), tag ); + } else { + result = NIL; + /* + * push back the character read + */ + url_ungetwc( initial, input ); + } + break; + } + + debug_print( L"read_symbol_or_key returning\n", DEBUG_IO ); + debug_dump_object( result, DEBUG_IO ); + + return result; +} + +/** + * 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 ) { + return read_continuation( frame, frame_pointer, env, input, + url_fgetwc( input ) ); +} diff --git a/src/ops/read.h b/src/io/read.h similarity index 69% rename from src/ops/read.h rename to src/io/read.h index c6dbba3..031bb4f 100644 --- a/src/ops/read.h +++ b/src/io/read.h @@ -11,10 +11,13 @@ #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, FILE * input ); + struct cons_pointer frame_pointer, + struct cons_pointer env, URL_FILE * input ); #endif diff --git a/src/memory/conspage.c b/src/memory/conspage.c index cf87028..f8802cc 100644 --- a/src/memory/conspage.c +++ b/src/memory/conspage.c @@ -16,16 +16,24 @@ #include #include -#include "consspaceobject.h" -#include "conspage.h" +#include "memory/consspaceobject.h" +#include "memory/conspage.h" #include "debug.h" -#include "dump.h" +#include "memory/dump.h" +#include "memory/stack.h" +#include "memory/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. */ @@ -43,9 +51,12 @@ struct cons_pointer freelist = NIL; struct cons_page *conspages[NCONSPAGES]; /** - * Make a cons page whose serial number (i.e. index in the conspages directory) is pageno. - * Initialise all cells and prepend each to the freelist; if pageno is zero, do not prepend - * cells 0 and 1 to the freelist but initialise them as NIL and T respectively. + * Make a cons page. Initialise all cells and prepend each to the freelist; + * if `initialised_cons_pages` is zero, do not prepend cells 0 and 1 to the + * freelist but initialise them as NIL and T respectively. + * \todo we ought to handle cons space exhaustion more gracefully than just + * crashing; should probably return an exception instead, although obviously + * that exception would have to have been pre-built. */ void make_cons_page( ) { struct cons_page *result = malloc( sizeof( struct cons_page ) ); @@ -66,7 +77,8 @@ void make_cons_page( ) { cell->count = MAXREFERENCE; cell->payload.free.car = NIL; cell->payload.free.cdr = NIL; - debug_printf( DEBUG_ALLOC, L"Allocated special cell NIL\n" ); + debug_printf( DEBUG_ALLOC, + L"Allocated special cell NIL\n" ); break; case 1: /* @@ -80,7 +92,8 @@ void make_cons_page( ) { cell->payload.free.cdr = ( struct cons_pointer ) { 0, 1 }; - debug_printf( DEBUG_ALLOC, L"Allocated special cell T\n" ); + debug_printf( DEBUG_ALLOC, + L"Allocated special cell T\n" ); break; } } else { @@ -98,19 +111,19 @@ void make_cons_page( ) { initialised_cons_pages++; } else { debug_printf( DEBUG_ALLOC, - L"FATAL: Failed to allocate memory for cons page %d\n", - initialised_cons_pages ); + L"FATAL: Failed to allocate memory for cons page %d\n", + initialised_cons_pages ); exit( 1 ); } } /** - * dump the allocated pages to this output stream. + * dump the allocated pages to this `output` stream. */ -void dump_pages( FILE * output ) { +void dump_pages( URL_FILE * output ) { for ( int i = 0; i < initialised_cons_pages; i++ ) { - fwprintf( output, L"\nDUMPING PAGE %d\n", i ); + url_fwprintf( output, L"\nDUMPING PAGE %d\n", i ); for ( int j = 0; j < CONSPAGESIZE; j++ ) { dump_object( output, ( struct cons_pointer ) { @@ -121,8 +134,9 @@ void dump_pages( FILE * output ) { } /** - * Frees the cell at the specified pointer. Dangerous, primitive, low - * level. + * Frees the cell at the specified `pointer`; for all the types of cons-space + * object which point to other cons-space objects, cascade the decrement. + * Dangerous, primitive, low level. * * @pointer the cell to free */ @@ -132,71 +146,77 @@ void free_cell( struct cons_pointer pointer ) { debug_printf( DEBUG_ALLOC, L"Freeing cell " ); debug_dump_object( pointer, DEBUG_ALLOC ); - switch ( cell->tag.value ) { - /* for all the types of cons-space object which point to other - * cons-space objects, cascade the decrement. */ - case CONSTV: - dec_ref( cell->payload.cons.car ); - dec_ref( cell->payload.cons.cdr ); - break; - case EXCEPTIONTV: - dec_ref( cell->payload.exception.message ); - break; - case FUNCTIONTV: - dec_ref( cell->payload.function.source ); - break; - case LAMBDATV: - case NLAMBDATV: - dec_ref( cell->payload.lambda.args ); - dec_ref( cell->payload.lambda.body ); - break; - case RATIOTV: - dec_ref( cell->payload.ratio.dividend ); - dec_ref( cell->payload.ratio.divisor ); - break; - case SPECIALTV: - dec_ref( cell->payload.special.source ); - break; - case STRINGTV: - case SYMBOLTV: - dec_ref( cell->payload.string.cdr ); - break; - case VECTORPOINTTV: - /* for vector space pointers, free the actual vector-space - * object. Dangerous! */ - debug_printf( DEBUG_ALLOC, L"About to free vector-space object at %ld\n", - cell->payload.vectorp.address ); - //free( ( void * ) cell->payload.vectorp.address ); - break; - - } - - if ( !check_tag( pointer, FREETAG ) ) { + if ( !check_tag( pointer, FREETV ) ) { if ( cell->count == 0 ) { + switch ( cell->tag.value ) { + case CONSTV: + dec_ref( cell->payload.cons.car ); + dec_ref( cell->payload.cons.cdr ); + break; + case EXCEPTIONTV: + dec_ref( cell->payload.exception.payload ); + dec_ref( cell->payload.exception.frame ); + break; + case FUNCTIONTV: + dec_ref( cell->payload.function.meta ); + break; + case INTEGERTV: + dec_ref( cell->payload.integer.more ); + break; + case LAMBDATV: + case NLAMBDATV: + dec_ref( cell->payload.lambda.args ); + dec_ref( cell->payload.lambda.body ); + break; + case RATIOTV: + dec_ref( cell->payload.ratio.dividend ); + dec_ref( cell->payload.ratio.divisor ); + break; + case READTV: + case WRITETV: + dec_ref( cell->payload.stream.meta ); + url_fclose( cell->payload.stream.stream ); + break; + case SPECIALTV: + dec_ref( cell->payload.special.meta ); + break; + case STRINGTV: + case SYMBOLTV: + dec_ref( cell->payload.string.cdr ); + break; + case VECTORPOINTTV: + free_vso( pointer ); + 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", - cell->count, pointer.page, pointer.offset ); + L"ERROR: Attempt to free cell with %d dangling references at page %d, offset %d\n", + cell->count, pointer.page, pointer.offset ); } } else { debug_printf( DEBUG_ALLOC, - L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n", - pointer.page, pointer.offset ); + L"ERROR: Attempt to free cell which is already FREE at page %d, offset %d\n", + pointer.page, pointer.offset ); } } /** - * Allocates a cell with the specified tag. Dangerous, primitive, low + * Allocates a cell with the specified `tag`. Dangerous, primitive, low * level. * * @param tag the tag of the cell to allocate - must be a valid cons space tag. * @return the cons pointer which refers to the cell allocated. + * \todo handle the case where another cons_page cannot be allocated; + * return an exception. Which, as we cannot create such an exception when + * cons space is exhausted, means we must construct it at init time. */ -struct cons_pointer allocate_cell( char *tag ) { +struct cons_pointer allocate_cell( uint32_t tag ) { struct cons_pointer result = freelist; @@ -209,15 +229,17 @@ struct cons_pointer allocate_cell( char *tag ) { if ( strncmp( &cell->tag.bytes[0], FREETAG, TAGLENGTH ) == 0 ) { freelist = cell->payload.free.cdr; - strncpy( &cell->tag.bytes[0], tag, TAGLENGTH ); + cell->tag.value = tag; 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 '%s' at %d, %d \n", tag, - result.page, result.offset ); + L"Allocated cell of type '%4.4s' at %d, %d \n", tag, + result.page, result.offset ); } else { debug_printf( DEBUG_ALLOC, L"WARNING: Allocating non-free cell!" ); } @@ -239,6 +261,12 @@ void initialise_cons_pages( ) { conspageinitihasbeencalled = true; } else { debug_printf( DEBUG_ALLOC, - L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); + L"WARNING: initialise_cons_pages() called a second or subsequent time\n" ); } } + +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 bc1361e..589f6bf 100644 --- a/src/memory/conspage.h +++ b/src/memory/conspage.h @@ -1,7 +1,19 @@ -#include "consspaceobject.h" +/* + * conspage.h + * + * Setup and tear down cons pages, and (FOR NOW) do primitive + * allocation/deallocation of cells. + * NOTE THAT before we go multi-threaded, these functions must be + * aggressively + * thread safe. + * + * (c) 2017 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ +#ifndef __psse_conspage_h +#define __psse_conspage_h -#ifndef __conspage_h -#define __conspage_h +#include "memory/consspaceobject.h" /** * the number of cons cells on a cons page. The maximum value this can @@ -9,7 +21,7 @@ * to) is the maximum value of an unsigned 32 bit integer, which is to * say 4294967296. However, we'll start small. */ -#define CONSPAGESIZE 8 +#define CONSPAGESIZE 1024 /** * the number of cons pages we will initially allow for. For @@ -25,7 +37,7 @@ * of addressable memory, which is only slightly more than the * number of atoms in the universe. */ -#define NCONSPAGES 8 +#define NCONSPAGES 64 /** * a cons page is essentially just an array of cons space objects. It @@ -37,42 +49,18 @@ struct cons_page { struct cons_space_object cell[CONSPAGESIZE]; }; -/** - * The (global) pointer to the (global) freelist. Not sure whether this ultimately - * belongs in this file. - */ extern struct cons_pointer freelist; -/** - * An array of pointers to cons pages. - */ extern struct cons_page *conspages[NCONSPAGES]; -/** - * Frees the cell at the specified pointer. Dangerous, primitive, low - * level. - * - * @pointer the cell to free - */ void free_cell( struct cons_pointer pointer ); -/** - * Allocates a cell with the specified tag. Dangerous, primitive, low - * level. - * - * @param tag the tag of the cell to allocate - must be a valid cons space tag. - * @return the cons pointer which refers to the cell allocated. - */ -struct cons_pointer allocate_cell( char *tag ); +struct cons_pointer allocate_cell( uint32_t tag ); -/** - * initialise the cons page system; to be called exactly once during startup. - */ void initialise_cons_pages( ); -/** - * dump the allocated pages to this output stream. - */ -void dump_pages( FILE * output ); +void dump_pages( URL_FILE * output ); + +void summarise_allocation( ); #endif diff --git a/src/memory/consspaceobject.c b/src/memory/consspaceobject.c index f5cc8b8..579e84b 100644 --- a/src/memory/consspaceobject.c +++ b/src/memory/consspaceobject.c @@ -18,18 +18,37 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" +#include "authorise.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "print.h" -#include "stack.h" +#include "ops/intern.h" +#include "io/print.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" /** - * Check that the tag on the cell at this pointer is this tag + * 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. */ -int check_tag( struct cons_pointer pointer, char *tag ) { +bool check_tag( struct cons_pointer pointer, uint32_t value ) { + bool result = false; + struct cons_space_object cell = pointer2cell( pointer ); - return strncmp( &cell.tag.bytes[0], tag, TAGLENGTH ) == 0; + 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; } /** @@ -37,13 +56,17 @@ int check_tag( struct cons_pointer pointer, char *tag ) { * * You can't roll over the reference count. Once it hits the maximum * value you cannot increment further. + * + * Returns the `pointer`. */ -void inc_ref( struct cons_pointer pointer ) { +struct cons_pointer inc_ref( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); if ( cell->count < MAXREFERENCE ) { cell->count++; } + + return pointer; } /** @@ -51,8 +74,10 @@ void 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. */ -void dec_ref( struct cons_pointer pointer ) { +struct cons_pointer dec_ref( struct cons_pointer pointer ) { struct cons_space_object *cell = &pointer2cell( pointer ); if ( cell->count > 0 ) { @@ -60,8 +85,90 @@ void dec_ref( struct cons_pointer pointer ) { if ( cell->count == 0 ) { free_cell( pointer ); + pointer = NIL; } } + + return pointer; +} + + +/** + * Get the Lisp type of the single argument. + * @param pointer a pointer to the object whose type is requested. + * @return As a Lisp string, the tag of the object which is at that pointer. + */ +struct cons_pointer c_type( struct cons_pointer pointer ) { + struct cons_pointer 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 ); + } + } + + 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. + */ +struct cons_pointer c_car( struct cons_pointer arg ) { + struct cons_pointer result = NIL; + + if ( truep( authorised( arg, NIL ) ) && consp( arg ) ) { + result = pointer2cell( arg ).payload.cons.car; + } + + return result; +} + +/** + * 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. + */ +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 ); + + switch ( cell->tag.value ) { + case CONSTV: + result = cell->payload.cons.cdr; + break; + case KEYTV: + case STRINGTV: + case SYMBOLTV: + result = cell->payload.string.cdr; + break; + } + } + + return result; +} + +/** + * Implementation of `length` in C. If arg is not a cons, does not error but returns 0. + */ +int c_length( struct cons_pointer arg ) { + int result = 0; + + for ( struct cons_pointer c = arg; !nilp( c ); c = c_cdr( c ) ) { + result++; + } + + return result; } @@ -72,7 +179,7 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr ) { struct cons_pointer pointer = NIL; - pointer = allocate_cell( CONSTAG ); + pointer = allocate_cell( CONSTV ); struct cons_space_object *cell = &pointer2cell( pointer ); @@ -92,14 +199,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( EXCEPTIONTAG ); + struct cons_pointer pointer = allocate_cell( EXCEPTIONTV ); struct cons_space_object *cell = &pointer2cell( pointer ); - inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ - inc_ref( message ); inc_ref( frame_pointer ); - cell->payload.exception.message = message; + cell->payload.exception.payload = message; cell->payload.exception.frame = frame_pointer; result = pointer; @@ -109,16 +214,17 @@ struct cons_pointer make_exception( struct cons_pointer message, /** - * Construct a cell which points to an executable Lisp special form. + * Construct a cell which points to an executable Lisp function. */ struct cons_pointer -make_function( struct cons_pointer src, struct cons_pointer ( *executable ) +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( FUNCTIONTAG ); + struct cons_pointer pointer = allocate_cell( FUNCTIONTV ); struct cons_space_object *cell = &pointer2cell( pointer ); + inc_ref( meta ); - cell->payload.function.source = src; + cell->payload.function.meta = meta; cell->payload.function.executable = executable; return pointer; @@ -129,7 +235,7 @@ make_function( struct cons_pointer src, struct cons_pointer ( *executable ) */ struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer body ) { - struct cons_pointer pointer = allocate_cell( LAMBDATAG ); + struct cons_pointer pointer = allocate_cell( LAMBDATV ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ @@ -148,7 +254,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( NLAMBDATAG ); + struct cons_pointer pointer = allocate_cell( NLAMBDATV ); inc_ref( pointer ); /* this is a hack; I don't know why it's necessary to do this, but if I don't the cell gets freed */ @@ -161,6 +267,37 @@ 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 @@ -168,58 +305,81 @@ struct cons_pointer make_nlambda( struct cons_pointer args, * pointer to next is NIL. */ struct cons_pointer -make_string_like_thing( wint_t c, struct cons_pointer tail, char *tag ) { +make_string_like_thing( wint_t c, struct cons_pointer tail, uint32_t tag ) { struct cons_pointer pointer = NIL; - if ( check_tag( tail, tag ) || check_tag( tail, NILTAG ) ) { + if ( check_tag( tail, tag ) || check_tag( tail, NILTV ) ) { pointer = allocate_cell( tag ); struct cons_space_object *cell = &pointer2cell( pointer ); inc_ref( tail ); cell->payload.string.character = c; cell->payload.string.cdr.page = tail.page; - /* TODO: There's a problem here. Sometimes the offsets on + /* \todo There's a problem here. Sometimes the offsets on * strings are quite massively off. Fix is probably - * cell->payload.string.cdr = tsil */ + * cell->payload.string.cdr = tail */ cell->payload.string.cdr.offset = tail.offset; + + cell->payload.string.hash = calculate_hash( c, tail ); } else { - // TODO: should throw an exception! + // \todo should throw an exception! debug_printf( DEBUG_ALLOC, - L"Warning: only NIL and %s can be prepended to %s\n", - tag, tag ); + L"Warning: only NIL and %4.4s can be prepended to %4.4s\n", + tag, tag ); } return pointer; } /** - * Construct a string from this character and - * this tail. A string is implemented as a flat list of cells each of which - * has one character and a pointer to the next; in the last cell the - * pointer to next is NIL. + * Construct a string from the character `c` and this `tail`. A string is + * implemented as a flat list of cells each of which has one character and a + * pointer to the next; in the last cell the pointer to next is NIL. + * + * @param c the character to add (prepend); + * @param tail the string which is being built. */ struct cons_pointer make_string( wint_t c, struct cons_pointer tail ) { - return make_string_like_thing( c, tail, STRINGTAG ); + return make_string_like_thing( c, tail, STRINGTV ); } /** - * Construct a symbol from this character and this tail. + * Construct a symbol or keyword from the character `c` and this `tail`. + * Each is internally identical to a string except for having a different tag. + * + * @param c the character to add (prepend); + * @param tail the symbol which is being built. + * @param tag the tag to use: expected to be "SYMB" or "KEYW" */ -struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ) { - return make_string_like_thing( c, tail, SYMBOLTAG ); +struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, + uint32_t tag ) { + struct cons_pointer result = make_string_like_thing( c, tail, tag ); + + if ( tag == KEYTV ) { + struct cons_pointer r = internedp( result, oblist ); + + if ( nilp( r ) ) { + intern( result, oblist ); + } else { + result = r; + } + } + + return result; } /** * Construct a cell which points to an executable Lisp special form. */ struct cons_pointer -make_special( struct cons_pointer src, struct cons_pointer ( *executable ) +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( SPECIALTAG ); + struct cons_pointer pointer = allocate_cell( SPECIALTV ); struct cons_space_object *cell = &pointer2cell( pointer ); + inc_ref( meta ); - cell->payload.special.source = src; + cell->payload.special.meta = meta; cell->payload.special.executable = executable; return pointer; @@ -228,37 +388,65 @@ make_special( struct cons_pointer src, struct cons_pointer ( *executable ) /** * Construct a cell which points to a stream open for reading. * @param input the C stream to wrap. + * @param metadata a pointer to an associaton containing metadata on the stream. + * @return a pointer to the new read stream. */ -struct cons_pointer make_read_stream( FILE * input ) { - struct cons_pointer pointer = allocate_cell( READTAG ); +struct cons_pointer make_read_stream( URL_FILE * input, + struct cons_pointer metadata ) { + struct cons_pointer pointer = allocate_cell( READTV ); struct cons_space_object *cell = &pointer2cell( pointer ); cell->payload.stream.stream = input; + cell->payload.stream.meta = metadata; return pointer; } /** - * Construct a cell which points to a stream open for writeing. + * Construct a cell which points to a stream open for writing. * @param output the C stream to wrap. + * @param metadata a pointer to an associaton containing metadata on the stream. + * @return a pointer to the new read stream. */ -struct cons_pointer make_write_stream( FILE * output ) { - struct cons_pointer pointer = allocate_cell( WRITETAG ); +struct cons_pointer make_write_stream( URL_FILE * output, + struct cons_pointer metadata ) { + struct cons_pointer pointer = allocate_cell( WRITETV ); struct cons_space_object *cell = &pointer2cell( pointer ); cell->payload.stream.stream = output; + cell->payload.stream.meta = metadata; return pointer; } +/** + * Return a lisp keyword representation of this wide character string. In keywords, + * I am accepting only lower case characters and numbers. + */ +struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ) { + struct cons_pointer result = NIL; + + 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 ); + } + } + + return result; +} + /** * Return a lisp string representation of this wide character string. */ struct cons_pointer c_string_to_lisp_string( wchar_t *string ) { struct cons_pointer result = NIL; - for ( int i = wcslen( string ); i > 0; i-- ) { - result = make_string( string[i - 1], result ); + for ( int i = wcslen( string ) - 1; i >= 0; i-- ) { + 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 523fdaa..7c3a390 100644 --- a/src/memory/consspaceobject.h +++ b/src/memory/consspaceobject.h @@ -1,4 +1,4 @@ -/** +/* * consspaceobject.h * * Declarations common to all cons space objects. @@ -8,6 +8,9 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#ifndef __psse_consspaceobject_h +#define __psse_consspaceobject_h + #include #include #include @@ -17,127 +20,231 @@ #include #include -#ifndef __consspaceobject_h -#define __consspaceobject_h +#include "io/fopen.h" +// #include "memory/conspage.h" + /** * The length of a tag, in bytes. */ #define TAGLENGTH 4 -/** - * tag values, all of which must be 4 bytes. Must not collide with vector space tag values +/* + * tag values, all of which must be 4 bytes. Must not collide with vector space + * tag values */ /** - * A word within a bignum - arbitrary precision integer. - */ -#define BIGNUMTAG "BIGN" -#define BIGNUMTV 1313294658 - -/** - * An ordinary cons cell: 1397641027 + * An ordinary cons cell: */ #define CONSTAG "CONS" + +/** + * The string `CONS`, considered as an `unsigned int`. + * @todo tag values should be collected into an enum. + */ #define CONSTV 1397641027 /** - * An exception. + * An exception. TODO: we need a means of dealing with different classes of + * exception, and we don't have one yet. */ #define EXCEPTIONTAG "EXEP" + +/** + * The string `EXEP`, considered as an `unsigned int`. + */ #define EXCEPTIONTV 1346721861 /** * An unallocated cell on the free list - should never be encountered by a Lisp - * function. 1162170950 + * function. */ #define FREETAG "FREE" + +/** + * The string `FREE`, considered as an `unsigned int`. + */ #define FREETV 1162170950 /** - * An ordinary Lisp function - one whose arguments are pre-evaluated and passed as - * a stack frame. 1129207110 + * An ordinary Lisp function - one whose arguments are pre-evaluated. + * \see LAMBDATAG for interpretable functions. + * \see SPECIALTAG for functions whose arguments are not pre-evaluated. */ #define FUNCTIONTAG "FUNC" -#define FUNCTIONTV 1129207110 + /** - * An integer number. 1381256777 + * The string `FUNC`, considered as an `unsigned int`. + */ +#define FUNCTIONTV 1129207110 + +/** + * An integer number (bignums are integers). */ #define INTEGERTAG "INTR" + +/** + * The string `INTR`, considered as an `unsigned int`. + */ #define INTEGERTV 1381256777 /** - * A lambda cell. + * A keyword - an interned, self-evaluating string. + */ +#define KEYTAG "KEYW" + +/** + * The string `KEYW`, considered as an `unsigned int`. + */ +#define KEYTV 1465468235 + +/** + * A lambda cell. Lambdas are the interpretable (source) versions of functions. + * \see FUNCTIONTAG. */ #define LAMBDATAG "LMDA" + +/** + * The string `LMDA`, considered as an `unsigned int`. + */ #define LAMBDATV 1094995276 /** - * The special cons cell at address {0,0} whose car and cdr both point to itself. - * 541870414 + * 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. */ #define NILTAG "NIL " + +/** + * The string `NIL `, considered as an `unsigned int`. + */ #define NILTV 541870414 /** - * An nlambda cell. + * An nlambda cell. NLambdas are the interpretable (source) versions of special + * forms. \see SPECIALTAG. */ #define NLAMBDATAG "NLMD" + +/** + * The string `NLMD`, considered as an `unsigned int`. + */ #define NLAMBDATV 1145916494 +/** + * A rational number, stored as pointers two integers representing dividend + * and divisor respectively. + */ +#define RATIOTAG "RTIO" + +/** + * The string `RTIO`, considered as an `unsigned int`. + */ +#define RATIOTV 1330205778 + /** * An open read stream. */ #define READTAG "READ" + +/** + * The string `READ`, considered as an `unsigned int`. + */ #define READTV 1145128274 /** - * A real number. + * A real number, represented internally as an IEEE 754-2008 `binary64`. */ #define REALTAG "REAL" + +/** + * The string `REAL`, considered as an `unsigned int`. + */ #define REALTV 1279346002 /** - * A ratio. - */ -#define RATIOTAG "RTIO" -#define RATIOTV 1330205778 - -/** - * A special form - one whose arguments are not pre-evaluated but passed as a - * s-expression. 1296453715 + * A special form - one whose arguments are not pre-evaluated but passed as + * provided. + * \see NLAMBDATAG. */ #define SPECIALTAG "SPFM" + +/** + * The string `SPFM`, considered as an `unsigned int`. + */ #define SPECIALTV 1296453715 /** - * A string of characters, organised as a linked list. 1196577875 + * A string of characters, organised as a linked list. */ #define STRINGTAG "STRG" + +/** + * The string `STRG`, considered as an `unsigned int`. + */ #define STRINGTV 1196577875 /** - * A symbol is just like a string except not self-evaluating. 1112365395 + * A symbol is just like a string except not self-evaluating. */ #define SYMBOLTAG "SYMB" + +/** + * The string `SYMB`, considered as an `unsigned int`. + */ #define SYMBOLTV 1112365395 /** - * The special cons cell at address {0,1} which is canonically different from NIL. - * 1163219540 + * A time stamp. + */ +#define TIMETAG "TIME" + +/** + * The string `TIME`, considered as an `unsigned int`. + */ +#define TIMETV 1162692948 + +/** + * The special cons cell at address {0,1} which is canonically different + * from NIL. */ #define TRUETAG "TRUE" + +/** + * The string `TRUE`, considered as an `unsigned int`. + */ #define TRUETV 1163219540 /** * A pointer to an object in vector space. */ #define VECTORPOINTTAG "VECP" + +/** + * The string `VECP`, considered as an `unsigned int`. + */ #define VECTORPOINTTV 1346585942 + /** * An open write stream. */ #define WRITETAG "WRIT" + +/** + * The string `WRIT`, considered as an `unsigned int`. + */ #define WRITETV 1414091351 /** @@ -160,104 +267,123 @@ */ #define tag2uint(tag) ((uint32_t)*tag) +/** + * given a cons_pointer as argument, return the cell. + */ #define pointer2cell(pointer) ((conspages[pointer.page]->cell[pointer.offset])) /** - * true if conspointer points to the special cell NIL, else false + * true if `conspoint` points to the special cell NIL, else false * (there should only be one of these so it's slightly redundant). */ -#define nilp(conspoint) (check_tag(conspoint,NILTAG)) +#define nilp(conspoint) (check_tag(conspoint,NILTV)) /** - * true if conspointer points to a cons cell, else false + * true if `conspoint` points to a cons cell, else false */ -#define bignump(conspoint) (check_tag(conspoint,BIGNUMTAG)) +#define consp(conspoint) (check_tag(conspoint,CONSTV)) /** - * true if conspointer points to a cons cell, else false + * true if `conspoint` points to an exception, else false */ -#define consp(conspoint) (check_tag(conspoint,CONSTAG)) +#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTV)) /** - * true if conspointer points to an exception, else false + * true if `conspoint` points to a function cell, else false */ -#define exceptionp(conspoint) (check_tag(conspoint,EXCEPTIONTAG)) +#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTV)) /** - * true if conspointer points to a function cell, else false + * true if `conspoint` points to a keyword, else false */ -#define functionp(conspoint) (check_tag(conspoint,FUNCTIONTAG)) +#define keywordp(conspoint) (check_tag(conspoint,KEYTV)) /** - * true if conspointer points to a special Lambda cell, else false + * true if `conspoint` points to a Lambda binding cell, else false */ -#define lambdap(conspoint) (check_tag(conspoint,LAMBDATAG)) +#define lambdap(conspoint) (check_tag(conspoint,LAMBDATV)) /** - * true if conspointer points to a special form cell, else false + * true if `conspoint` points to a loop recursion, else false. */ -#define specialp(conspoint) (check_tag(conspoint,SPECIALTAG)) +#define loopp(conspoint) (check_tag(conspoint,LOOPTV)) /** - * true if conspointer points to a string cell, else false + * true if `conspoint` points to a special form cell, else false */ -#define stringp(conspoint) (check_tag(conspoint,STRINGTAG)) +#define specialp(conspoint) (check_tag(conspoint,SPECIALTV)) /** - * true if conspointer points to a symbol cell, else false + * true if `conspoint` points to a string cell, else false */ -#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTAG)) +#define stringp(conspoint) (check_tag(conspoint,STRINGTV)) /** - * true if conspointer points to an integer cell, else false + * true if `conspoint` points to a symbol cell, else false */ -#define integerp(conspoint) (check_tag(conspoint,INTEGERTAG)) +#define symbolp(conspoint) (check_tag(conspoint,SYMBOLTV)) /** - * true if conspointer points to a rational number cell, else false + * true if `conspoint` points to an integer cell, else false */ -#define ratiop(conspoint) (check_tag(conspoint,RATIOTAG)) +#define integerp(conspoint) (check_tag(conspoint,INTEGERTV)) /** - * true if conspointer points to a read stream cell, else false + * true if `conspoint` points to a rational number cell, else false */ -#define readp(conspoint) (check_tag(conspoint,READTAG)) +#define ratiop(conspoint) (check_tag(conspoint,RATIOTV)) /** - * true if conspointer points to a real number cell, else false + * true if `conspoint` points to a read stream cell, else false */ -#define realp(conspoint) (check_tag(conspoint,REALTAG)) +#define readp(conspoint) (check_tag(conspoint,READTV)) /** - * true if conspointer points to some sort of a number cell, + * true if `conspoint` points to a real number cell, else false + */ +#define realp(conspoint) (check_tag(conspoint,REALTV)) + +/** + * true if `conspoint` points to some sort of a number cell, * else false */ -#define numberp(conspoint) (check_tag(conspoint,INTEGERTAG)||check_tag(conspoint,RATIOTAG)||check_tag(conspoint,REALTAG)||check_tag(conspoint,BIGNUMTAG)) - -#define sequencep(conspoint) (check_tag(conspoint,CONSTAG)||check_tag(conspoint,STRINGTAG)||check_tag(conspoint,SYMBOLTAG)) +#define numberp(conspoint) (check_tag(conspoint,INTEGERTV)||check_tag(conspoint,RATIOTV)||check_tag(conspoint,REALTV)) /** - * true if thr conspointer points to a vector pointer. + * true if `conspoint` points to a sequence (list, string or, later, vector), + * else false. */ -#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTAG)) +#define sequencep(conspoint) (check_tag(conspoint,CONSTV)||check_tag(conspoint,STRINGTV)||check_tag(conspoint,SYMBOLTV)) /** - * true if conspointer points to a write stream cell, else false. + * true if `conspoint` points to a vector pointer, else false. */ -#define writep(conspoint) (check_tag(conspoint,WRITETAG)) +#define vectorpointp(conspoint) (check_tag(conspoint,VECTORPOINTTV)) /** - * true if conspointer points to a true cell, else false + * true if `conspoint` points to a write stream cell, else false. + */ +#define writep(conspoint) (check_tag(conspoint,WRITETV)) + +#define streamp(conspoint) (check_tag(conspoint,READTV)||check_tag(conspoint,WRITETV)) + +/** + * true if `conspoint` points to a true cell, else false * (there should only be one of these so it's slightly redundant). * Also note that anything that is not NIL is truthy. */ -#define tp(conspoint) (checktag(conspoint,TRUETAG)) +#define tp(conspoint) (check_tag(conspoint,TRUETV)) /** - * true if conspoint points to something that is truthy, i.e. + * true if `conspoint` points to a time cell, else false. + */ +#define timep(conspoint) (check_tag(conspoint,TIMETV)) + +/** + * true if `conspoint` points to something that is truthy, i.e. * anything but NIL. */ -#define truep(conspoint) (!checktag(conspoint,NILTAG)) +#define truep(conspoint) (!check_tag(conspoint,NILTV)) /** * An indirect pointer to a cons cell @@ -276,34 +402,28 @@ struct cons_pointer { /** * A stack frame. Yes, I know it isn't a cons-space object, but it's defined - * here to avoid circularity. TODO: refactor. + * here to avoid circularity. \todo refactor. */ struct stack_frame { - struct cons_pointer previous; /* the previous frame */ + /** the previous frame. */ + struct cons_pointer previous; + /** first 8 arument bindings. */ struct cons_pointer arg[args_in_frame]; - /* - * first 8 arument bindings - */ - struct cons_pointer more; /* list of any further argument bindings */ - struct cons_pointer function; /* the function to be called */ + /** list of any further argument bindings. */ + struct cons_pointer more; + /** the function to be called. */ + struct cons_pointer function; + /** the number of arguments provided. */ int args; }; -/** - * payload of a bignum cell. Intentionally similar to an integer payload, but - * with a next pointer. - */ -struct bignum_payload { - int64_t value; - struct cons_pointer next; -}; - - /** * payload of a cons cell. */ struct cons_payload { + /** Contents of the Address Register, naturally. */ struct cons_pointer car; + /** Contents of the Decrement Register, naturally. */ struct cons_pointer cdr; }; @@ -312,7 +432,9 @@ struct cons_payload { * Message should be a Lisp string; frame should be a pointer to an (unfreed) stack frame. */ struct exception_payload { - struct cons_pointer message; + /** The payload: usually a Lisp string but in practice anything printable will do. */ + struct cons_pointer payload; + /** pointer to the (unfreed) stack frame in which the exception was thrown. */ struct cons_pointer frame; }; @@ -326,7 +448,16 @@ struct exception_payload { * result). */ struct function_payload { - struct cons_pointer source; + /** + * pointer to metadata (e.g. the source from which the function was compiled). + */ + struct cons_pointer meta; + /** pointer to a function which takes a cons pointer (representing + * its argument list) and a cons pointer (representing its environment) and a + * stack frame (representing the previous stack frame) as arguments and returns + * a cons pointer (representing its result). + * \todo check this documentation is current! + */ struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ); @@ -342,27 +473,37 @@ struct free_payload { }; /** - * payload of an integer cell. For the time being just a signed integer; - * later might be a signed 128 bit integer, or might have some flag to point to an - * optional bignum object. + * payload of an integer cell. An integer is in principle a sequence of cells; + * only 60 bits (+ sign bit) are actually used in each cell. If the value + * exceeds 60 bits, the least significant 60 bits are stored in the first cell + * in the chain, the next 60 in the next cell, and so on. Only the value of the + * first cell in any chain should be negative. */ struct integer_payload { + /** the value of the payload (i.e. 60 bits) of this cell. */ int64_t value; + /** the next (more significant) cell in the chain, ir `NIL` if there are no + * more. */ + struct cons_pointer more; }; /** - * payload for lambda and nlambda cells + * payload for lambda and nlambda cells. */ struct lambda_payload { + /** the arument list */ struct cons_pointer args; + /** the body of the function to be applied to the arguments. */ struct cons_pointer body; }; /** - * payload for ratio cells. Both dividend and divisor must point to integer (or, later, bignum) cells. + * payload for ratio cells. Both `dividend` and `divisor` must point to integer cells. */ struct ratio_payload { + /** a pointer to an integer representing the dividend */ struct cons_pointer dividend; + /** a pointer to an integer representing the divisor. */ struct cons_pointer divisor; }; @@ -371,20 +512,25 @@ struct ratio_payload { * precision, but I'm not sure of the detail. */ struct real_payload { + /** the value of the number */ long double value; }; /** - * Payload of a special form cell. - * source points to the source from which the function was compiled, or NIL - * if it is a primitive. - * executable points to a function which takes a cons pointer (representing - * its argument list) and a cons pointer (representing its environment) and a - * stack frame (representing the previous stack frame) as arguments and returns - * a cons pointer (representing its result). + * Payload of a special form cell. Currently identical to the payload of a + * function cell. + * \see function_payload */ struct special_payload { - struct cons_pointer source; + /** + * pointer to the source from which the special form was compiled, or NIL + * if it is a primitive. + */ + struct cons_pointer meta; + /** pointer to a function which takes a cons pointer (representing + * its argument list) and a cons pointer (representing its environment) and a + * stack frame (representing the previous stack frame) as arguments and returns + * a cons pointer (representing its result). */ struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ); @@ -394,38 +540,58 @@ struct special_payload { * payload of a read or write stream cell. */ struct stream_payload { - FILE *stream; + /** the stream to read from or write to. */ + URL_FILE *stream; + /** metadata on the stream (e.g. its file attributes if a file, its HTTP + * headers if a URL, etc). Expected to be an association, or nil. Not yet + * implemented. */ + struct cons_pointer meta; }; /** * payload of a string cell. At least at first, only one UTF character will * be stored in each cell. The doctrine that 'a symbol is just a string' - * didn't work; however, the payload of a symbol cell is identical to the - * payload of a string cell. + * didn't work; however, the payload of a symbol or keyword cell is identical + * to the payload of a string cell, except that a keyword may store a hash + * of its own value in the padding. */ struct string_payload { - wint_t character; /* the actual character stored in this cell */ - uint32_t padding; /* unused padding to word-align the cdr */ + /** the actual character stored in this cell */ + wint_t character; + /** a hash of the string value, computed at store time. */ + uint32_t hash; + /** the remainder of the string following this character. */ struct cons_pointer cdr; }; +/** + * The payload of a time cell: an unsigned 128 bit value representing micro- + * seconds since the estimated date of the Big Bang (actually, for + * convenience, 14Bn years before 1st Jan 1970 (the UNIX epoch)) + */ +struct time_payload { + unsigned __int128 value; +}; + /** * payload of a vector pointer cell. */ struct vectorp_payload { + /** the tag of the vector-space object. NOTE that the vector space object + * should itself have the identical tag. */ union { - char bytes[TAGLENGTH]; /* the tag (type) of the - * vector-space object this cell - * points to, considered as bytes. - * NOTE that the vector space object - * should itself have the identical - * tag. */ - uint32_t value; /* the tag considered as a number */ + /** the tag (type) of the vector-space object this cell + * points to, considered as bytes. */ + char bytes[TAGLENGTH]; + /** the tag considered as a number */ + uint32_t value; } tag; - void *address; - /* the address of the actual vector space - * object (TODO: will change when I actually + /** unused padding to word-align the address */ + uint32_t padding; + /** the address of the actual vector space + * object (\todo will change when I actually * implement vector space) */ + void *address; }; /** @@ -433,88 +599,93 @@ struct vectorp_payload { */ struct cons_space_object { union { - char bytes[TAGLENGTH]; /* the tag (type) of this cell, - * considered as bytes */ - uint32_t value; /* the tag considered as a number */ + /** the tag (type) of this cell, + * considered as bytes */ + char bytes[TAGLENGTH]; + /** the tag considered as a number */ + uint32_t value; } tag; - uint32_t count; /* the count of the number of references to - * this cell */ - struct cons_pointer access; /* cons pointer to the access control list of - * this cell */ + /** the count of the number of references to this cell */ + uint32_t count; + /** cons pointer to the access control list of this cell */ + struct cons_pointer access; union { - /* + /** * if tag == CONSTAG */ struct cons_payload cons; - /* - * if tag == EXCEPTIONTAG + /** + * if tag == EXCEPTIONTAG || tag == LOOPTAG */ struct exception_payload exception; - /* + /** * if tag == FREETAG */ struct free_payload free; - /* + /** * if tag == FUNCTIONTAG */ struct function_payload function; - /* + /** * if tag == INTEGERTAG */ struct integer_payload integer; - /* + /** * if tag == LAMBDATAG or NLAMBDATAG */ struct lambda_payload lambda; - /* + /** * if tag == NILTAG; we'll treat the special cell NIL as just a cons */ struct cons_payload nil; - /* + /** * if tag == RATIOTAG */ struct ratio_payload ratio; - /* + /** * if tag == READTAG || tag == WRITETAG */ struct stream_payload stream; - /* + /** * if tag == REALTAG */ struct real_payload real; - /* + /** * if tag == SPECIALTAG */ struct special_payload special; - /* + /** * if tag == STRINGTAG || tag == SYMBOLTAG */ struct string_payload string; - /* + /** + * if tag == TIMETAG + */ + struct time_payload time; + /** * if tag == TRUETAG; we'll treat the special cell T as just a cons */ struct cons_payload t; - /* + /** * if tag == VECTORPTAG */ struct vectorp_payload vectorp; } payload; }; -/** - * Check that the tag on the cell at this pointer is this tag - */ -int check_tag( struct cons_pointer pointer, char *tag ); +bool check_tag( struct cons_pointer pointer, uint32_t value ); -/** - * increment the reference count of the object at this cons pointer - */ -void inc_ref( struct cons_pointer pointer ); +struct cons_pointer inc_ref( struct cons_pointer pointer ); -/** - * decrement the reference count of the object at this cons pointer - */ -void dec_ref( struct cons_pointer pointer ); +struct cons_pointer dec_ref( struct cons_pointer pointer ); + +struct cons_pointer c_type( struct cons_pointer pointer ); + +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 ); struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer cdr ); @@ -522,71 +693,46 @@ struct cons_pointer make_cons( struct cons_pointer car, struct cons_pointer make_exception( struct cons_pointer message, struct cons_pointer frame_pointer ); -/** - * Construct a cell which points to an executable Lisp special form. - */ struct cons_pointer make_function( struct cons_pointer src, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ); -/** - * Construct a lambda (interpretable source) cell - */ +struct cons_pointer c_string_to_lisp_keyword( wchar_t *symbol ); + struct cons_pointer make_lambda( struct cons_pointer args, struct cons_pointer body ); -/** - * Construct an nlambda (interpretable source) cell; to a - * lambda as a special form is to a function. - */ struct cons_pointer make_nlambda( struct cons_pointer args, struct cons_pointer body ); -/** - * Construct a cell which points to an executable Lisp special form. - */ struct cons_pointer make_special( struct cons_pointer src, struct cons_pointer ( *executable ) ( struct stack_frame *, struct cons_pointer, struct cons_pointer ) ); -/** - * Construct a string from this character and this tail. A string is - * implemented as a flat list of cells each of which has one character and a - * pointer to the next; in the last cell the pointer to next is NIL. - */ +struct cons_pointer make_string_like_thing( wint_t c, struct cons_pointer tail, + uint32_t tag ); + struct cons_pointer make_string( wint_t c, struct cons_pointer tail ); -/** - * Construct a symbol from this character and this tail. A symbol is identical - * to a string except for having a different tag. - */ -struct cons_pointer make_symbol( wint_t c, struct cons_pointer tail ); +struct cons_pointer make_symbol_or_key( wint_t c, struct cons_pointer tail, + uint32_t tag ); -/** - * Construct a cell which points to a stream open for reading. - * @param input the C stream to wrap. - */ -struct cons_pointer make_read_stream( FILE * input ); +#define make_symbol(c, t) (make_symbol_or_key( c, t, SYMBOLTV)) -/** - * Construct a cell which points to a stream open for writeing. - * @param output the C stream to wrap. - */ -struct cons_pointer make_write_stream( FILE * output ); +#define make_keyword(c, t) (make_symbol_or_key( c, t, KEYTV)) +struct cons_pointer make_read_stream( URL_FILE * input, + struct cons_pointer metadata ); + +struct cons_pointer make_write_stream( URL_FILE * output, + struct cons_pointer metadata ); -/** - * Return a lisp string representation of this old skool ASCII string. - */ struct cons_pointer c_string_to_lisp_string( wchar_t *string ); -/** - * Return a lisp symbol representation of this old skool ASCII string. - */ struct cons_pointer c_string_to_lisp_symbol( wchar_t *symbol ); #endif diff --git a/src/memory/dump.c b/src/memory/dump.c index e88332a..2bc5bb0 100644 --- a/src/memory/dump.c +++ b/src/memory/dump.c @@ -18,94 +18,115 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "print.h" -#include "stack.h" -#include "vectorspace.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" -void dump_string_cell( FILE * output, wchar_t *prefix, +void dump_string_cell( URL_FILE * output, wchar_t *prefix, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); if ( cell.payload.string.character == 0 ) { - fwprintf( output, - L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", - prefix, - cell.payload.string.cdr.page, cell.payload.string.cdr.offset, - cell.count ); + url_fwprintf( output, + L"\t\t%ls cell: termination; next at page %d offset %d, count %u\n", + prefix, + cell.payload.string.cdr.page, + cell.payload.string.cdr.offset, cell.count ); } else { - fwprintf( output, - L"\t\t%ls cell: character '%lc' (%d) next at page %d offset %d, count %u\n", - prefix, - ( wint_t ) cell.payload.string.character, - cell.payload.string.character, - cell.payload.string.cdr.page, - cell.payload.string.cdr.offset, cell.count ); - fwprintf( output, L"\t\t value: " ); + url_fwprintf( output, + L"\t\t%ls cell: character '%lc' (%d) with hash %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: " ); print( output, pointer ); - fwprintf( output, L"\n" ); + url_fwprintf( output, L"\n" ); } } /** * dump the object at this cons_pointer to this output stream. */ -void dump_object( FILE * output, struct cons_pointer pointer ) { +void dump_object( URL_FILE * output, struct cons_pointer pointer ) { struct cons_space_object cell = pointer2cell( pointer ); - fwprintf( output, - L"\t%4.4s (%d) at page %d, offset %d count %u\n", - cell.tag.bytes, - cell.tag.value, pointer.page, pointer.offset, cell.count ); + url_fwprintf( output, L"\t%4.4s (%d) at page %d, offset %d count %u\n", + cell.tag.bytes, cell.tag.value, pointer.page, pointer.offset, + cell.count ); switch ( cell.tag.value ) { case CONSTV: - fwprintf( output, - L"\t\tCons cell: car at page %d offset %d, cdr at page %d offset %d, count %u :", - cell.payload.cons.car.page, - cell.payload.cons.car.offset, - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset, cell.count ); - print( output, pointer); - fputws( L"\n", output); + url_fwprintf( output, + L"\t\tCons cell: car at page %d offset %d, cdr at page %d " + L"offset %d, count %u :", + cell.payload.cons.car.page, + cell.payload.cons.car.offset, + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset, cell.count ); + print( output, pointer ); + url_fputws( L"\n", output ); break; case EXCEPTIONTV: - fwprintf( output, L"\t\tException cell: " ); + url_fwprintf( output, L"\t\tException cell: " ); dump_stack_trace( output, pointer ); break; case FREETV: - fwprintf( output, L"\t\tFree cell: next at page %d offset %d\n", - cell.payload.cons.cdr.page, - cell.payload.cons.cdr.offset ); + url_fwprintf( output, + L"\t\tFree cell: next at page %d offset %d\n", + cell.payload.cons.cdr.page, + cell.payload.cons.cdr.offset ); break; case INTEGERTV: - fwprintf( output, - L"\t\tInteger cell: value %ld, count %u\n", - cell.payload.integer.value, cell.count ); + url_fwprintf( output, L"\t\tInteger cell: value %ld, count %u\n", + cell.payload.integer.value, cell.count ); + if ( !nilp( cell.payload.integer.more ) ) { + url_fputws( L"\t\tBIGNUM! More at:\n", output ); + dump_object( output, cell.payload.integer.more ); + } + break; + case KEYTV: + dump_string_cell( output, L"Keyword", pointer ); break; case LAMBDATV: - fwprintf( output, L"\t\tLambda cell; args: " ); + url_fwprintf( output, L"\t\t\u03bb cell;\n\t\t args: " ); print( output, cell.payload.lambda.args ); - fwprintf( output, L";\n\t\t\tbody: " ); + url_fwprintf( output, L";\n\t\t\tbody: " ); print( output, cell.payload.lambda.body ); + url_fputws( L"\n", output ); break; case NILTV: break; + case NLAMBDATV: + url_fwprintf( output, L"\t\tn\u03bb cell; \n\t\targs: " ); + print( output, cell.payload.lambda.args ); + url_fwprintf( output, L";\n\t\t\tbody: " ); + print( output, cell.payload.lambda.body ); + url_fputws( L"\n", output ); + break; case RATIOTV: - fwprintf( output, - L"\t\tRational cell: value %ld/%ld, count %u\n", - pointer2cell( cell.payload.ratio.dividend ). - payload.integer.value, - pointer2cell( cell.payload.ratio.divisor ). - payload.integer.value, cell.count ); + url_fwprintf( output, + L"\t\tRational cell: value %ld/%ld, count %u\n", + pointer2cell( cell.payload.ratio.dividend ).payload. + integer.value, + pointer2cell( cell.payload.ratio.divisor ).payload. + integer.value, cell.count ); break; case READTV: - fwprintf( output, L"\t\tInput stream\n" ); + url_fputws( L"\t\tInput stream; metadata: ", output ); + print( output, cell.payload.stream.meta ); + url_fputws( L"\n", output ); break; case REALTV: - fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", - cell.payload.real.value, cell.count ); + url_fwprintf( output, L"\t\tReal cell: value %Lf, count %u\n", + cell.payload.real.value, cell.count ); break; case STRINGTV: dump_string_cell( output, L"String", pointer ); @@ -116,25 +137,30 @@ void dump_object( FILE * output, struct cons_pointer pointer ) { case TRUETV: break; case VECTORPOINTTV:{ - fwprintf( output, - L"\t\tPointer to vector-space object at %p\n", - cell.payload.vectorp.address ); + url_fwprintf( output, + L"\t\tPointer to vector-space object at %p\n", + cell.payload.vectorp.address ); struct vector_space_object *vso = cell.payload.vectorp.address; - fwprintf( output, - L"\t\tVector space object of type %4.4s (%d), payload size %d bytes\n", - &vso->header.tag.bytes, vso->header.tag.value, vso->header.size ); - if (stackframep(vso)) { - dump_frame(output, pointer); - } + url_fwprintf( output, + L"\t\tVector space object of type %4.4s (%d), payload size " + L"%d bytes\n", + &vso->header.tag.bytes, vso->header.tag.value, + vso->header.size ); + switch ( vso->header.tag.value ) { case STACKFRAMETV: dump_frame( output, pointer ); break; + case HASHTV: + dump_map( output, pointer ); + break; } } break; case WRITETV: - fwprintf( output, L"\t\tOutput stream\n" ); + url_fputws( L"\t\tOutput stream; metadata: ", output ); + print( output, cell.payload.stream.meta ); + url_fputws( L"\n", output ); break; } } diff --git a/src/memory/dump.h b/src/memory/dump.h index e49f453..f8ef75f 100644 --- a/src/memory/dump.h +++ b/src/memory/dump.h @@ -1,4 +1,4 @@ -/** +/* * dump.h * * Dump representations of both cons space and vector space objects. @@ -20,10 +20,6 @@ #define __dump_h -/** - * dump the object at this cons_pointer to this output stream. - */ -void dump_object( FILE * output, struct cons_pointer pointer ); - +void dump_object( URL_FILE * output, struct cons_pointer pointer ); #endif diff --git a/src/memory/hashmap.c b/src/memory/hashmap.c new file mode 100644 index 0000000..5e1db0a --- /dev/null +++ b/src/memory/hashmap.c @@ -0,0 +1,356 @@ +/* + * 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 new file mode 100644 index 0000000..b6c4a74 --- /dev/null +++ b/src/memory/hashmap.h @@ -0,0 +1,55 @@ +/* + * 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 new file mode 100644 index 0000000..359cff2 --- /dev/null +++ b/src/memory/lookup3.c @@ -0,0 +1,1281 @@ +/* +------------------------------------------------------------------------------- +lookup3.c, by Bob Jenkins, May 2006, Public Domain. + +These are functions for producing 32-bit hashes for hash table lookup. +hashword(), hashlittle(), hashlittle2(), hashbig(), mix(), and final() +are externally useful functions. Routines to test the hash are included +if SELF_TEST is defined. You can use this free for any purpose. It's in +the public domain. It has no warranty. + +You probably want to use hashlittle(). hashlittle() and hashbig() +hash byte arrays. hashlittle() is is faster than hashbig() on +little-endian machines. Intel and AMD are little-endian machines. +On second thought, you probably want hashlittle2(), which is identical to +hashlittle() except it returns two 32-bit hashes for the price of one. +You could implement hashbig2() if you wanted but I haven't bothered here. + +If you want to find a hash of, say, exactly 7 integers, do + a = i1; b = i2; c = i3; + mix(a,b,c); + a += i4; b += i5; c += i6; + mix(a,b,c); + a += i7; + final(a,b,c); +then use c as the hash value. If you have a variable length array of +4-byte integers to hash, use hashword(). If you have a byte array (like +a character string), use hashlittle(). If you have several byte arrays, or +a mix of things, see the comments above hashlittle(). + +Why is this so big? I read 12 bytes at a time into 3 4-byte integers, +then mix those integers. This is fast (you can do a lot more thorough +mixing with 12*3 instructions on 3 integers than you can with 3 instructions +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 */ +#ifdef linux +#include /* attempt to define endianness */ +#endif + +/* + * My best guess at if you are big-endian or little-endian. This may + * need adjustment. + */ +#if (defined(__BYTE_ORDER) && defined(__LITTLE_ENDIAN) && \ + __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 +#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 +#else +#define HASH_LITTLE_ENDIAN 0 +#define HASH_BIG_ENDIAN 0 +#endif + +#define hashsize(n) ((uint32_t)1<<(n)) +#define hashmask(n) (hashsize(n)-1) +#define rot(x,k) (((x)<<(k)) | ((x)>>(32-(k)))) + +/* +------------------------------------------------------------------------------- +mix -- mix 3 32-bit values reversibly. + +This is reversible, so any information in (a,b,c) before mix() is +still in (a,b,c) after mix(). + +If four pairs of (a,b,c) inputs are run through mix(), or through +mix() in reverse, there are at least 32 bits of the output that +are sometimes the same for one pair and different for another pair. +This was tested for: +* pairs that differed by one bit, by two bits, in any combination + of top bits of (a,b,c), or in any combination of bottom bits of + (a,b,c). +* "differ" is defined as +, -, ^, or ~^. For + and -, I transformed + the output delta to a Gray code (a^(a>>1)) so a string of 1's (as + is commonly produced by subtraction) look like a single 1-bit + difference. +* the base values were pseudorandom, all zero but one bit set, or + all zero plus a counter that starts at zero. + +Some k values for my "a-=c; a^=rot(c,k); c+=b;" arrangement that +satisfy this are + 4 6 8 16 19 4 + 9 15 3 18 27 15 + 14 9 3 7 17 3 +Well, "9 15 3 18 27 15" didn't quite get 32 bits diffing +for "differ" defined as + with a one-bit base and a two-bit delta. I +used http://burtleburtle.net/bob/hash/avalanche.html to choose +the operations, constants, and arrangements of the variables. + +This does not achieve avalanche. There are input bits of (a,b,c) +that fail to affect some output bits of (a,b,c), especially of a. The +most thoroughly mixed value is c, but it doesn't really even achieve +avalanche in c. + +This allows some parallelism. Read-after-writes are good at doubling +the number of bits affected, so the goal of mixing pulls in the opposite +direction as the goal of parallelism. I did what I could. Rotates +seem to cost as much as shifts on every machine I could lay my hands +on, and rotates are much kinder to the top and bottom bits, so I used +rotates. +------------------------------------------------------------------------------- +*/ +#define mix(a,b,c) \ +{ \ + a -= c; a ^= rot(c, 4); c += b; \ + b -= a; b ^= rot(a, 6); a += c; \ + c -= b; c ^= rot(b, 8); b += a; \ + a -= c; a ^= rot(c,16); c += b; \ + b -= a; b ^= rot(a,19); a += c; \ + c -= b; c ^= rot(b, 4); b += a; \ +} + +/* +------------------------------------------------------------------------------- +final -- final mixing of 3 32-bit values (a,b,c) into c + +Pairs of (a,b,c) values differing in only a few bits will usually +produce values of c that look totally different. This was tested for +* pairs that differed by one bit, by two bits, in any combination + of top bits of (a,b,c), or in any combination of bottom bits of + (a,b,c). +* "differ" is defined as +, -, ^, or ~^. For + and -, I transformed + the output delta to a Gray code (a^(a>>1)) so a string of 1's (as + is commonly produced by subtraction) look like a single 1-bit + difference. +* the base values were pseudorandom, all zero but one bit set, or + all zero plus a counter that starts at zero. + +These constants passed: + 14 11 25 16 4 14 24 + 12 14 25 16 4 14 24 +and these came close: + 4 8 15 26 3 22 24 + 10 8 15 26 3 22 24 + 11 8 15 26 3 22 24 +------------------------------------------------------------------------------- +*/ +#define final(a,b,c) \ +{ \ + c ^= b; c -= rot(b,14); \ + a ^= c; a -= rot(c,11); \ + b ^= a; b -= rot(a,25); \ + c ^= b; c -= rot(b,16); \ + a ^= c; a -= rot(c,4); \ + b ^= a; b -= rot(a,14); \ + c ^= b; c -= rot(b,24); \ +} + +/* +-------------------------------------------------------------------- + This works on all machines. To be useful, it requires + -- that the key be an array of uint32_t's, and + -- that the length be the number of uint32_t's in the key + + The function hashword() is identical to hashlittle() on little-endian + machines, and identical to hashbig() on big-endian machines, + except that the length has to be measured in uint32_ts rather than in + bytes. hashlittle() is more complicated than hashword() only because + 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; + + /* 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; + } + + /*------------------------------------------- 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; + } + /*------------------------------------------------------ report the result */ + return c; +} + + +/* +-------------------------------------------------------------------- +hashword2() -- same as hashword(), but take two seeds and return two +32-bit values. pc and pb must both be nonnull, and *pc and *pb must +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; + + /* 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; + } + + /*------------------------------------------- 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; + } + /*------------------------------------------------------ report the result */ + *pc = c; + *pb = b; +} + + +/* +------------------------------------------------------------------------------- +hashlittle() -- hash a variable-length key into a 32-bit value + k : the key (the unaligned variable-length array of bytes) + length : the length of the key, counting by bytes + initval : can be any 4-byte value +Returns a 32-bit value. Every bit of the key affects every bit of +the return value. Two keys differing by one or two bits will have +totally different hash values. + +The best hash table sizes are powers of 2. There is no need to do +mod a prime (mod is sooo slow!). If you need less than 32 bits, +use a bitmask. For example, if you need only 10 bits, do + h = (h & hashmask(10)); +In which case, the hash table should have hashsize(10) elements. + +If you are hashing n strings (uint8_t **)k, do it like this: + for (i=0, h=0; i 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). + */ +#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 */ + } + +#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; + } + +#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; + + /*--------------- 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; + } + } + + final( a, b, c ); + return c; +} + + +/* + * hashlittle2: return 2 32-bit hash values + * + * This is identical to hashlittle(), except it returns two 32-bit hash + * values instead of just one. This is good enough for hash table + * lookup with 2^^64 buckets, or if you want a second hash if you're not + * happy with the first, or if you want a probably-unique 64-bit ID for + * 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 */ + + /* 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; + + /*------ 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; + } + + /*----------------------------- 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). + */ +#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 */ + } + +#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 */ + } + +#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; + + /*--------------- 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 */ + } + } + + final( a, b, c ); + *pc = c; + *pb = b; +} + + + +/* + * hashbig(): + * This is the same as hashword() on big-endian machines. It is different + * 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 */ + + /* 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; + + /*------ 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; + } + + /*----------------------------- 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). + */ +#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 */ + } + +#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; + } + +#endif /* !VALGRIND */ + + } 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; + } + } + + 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; + + 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 */ +#define HASHSTATE 1 +#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; + + 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 ); + + /*---- check that every output bit is affected by that input bit */ + for ( k = 0; k < MAXPAIR; k += 2 ) { + uint32_t finished = 1; + /* keys have one bit different */ + for ( l = 0; l < hlen + 1; ++l ) { + a[l] = b[l] = ( uint8_t ) 0; + } + /* have a and b be two keys differing in only one bit */ + a[i] ^= ( k << j ); + a[i] ^= ( k >> ( 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 ); + } + } + 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; + + 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 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; + + /* these should all be equal */ + ref = hashlittle( b, len, ( uint32_t ) 1 ); + *( b + i ) = ( uint8_t ) ~ 0; + *( b - 1 ) = ( uint8_t ) ~ 0; + x = hashlittle( b, len, ( uint32_t ) 1 ); + y = hashlittle( b, len, ( uint32_t ) 1 ); + if ( ( ref != x ) || ( ref != y ) ) { + printf( "alignment error: %.8x %.8x %.8x %d %d\n", ref, x, y, + h, i ); + } + } + } +} + +/* check for problems with nulls */ +void driver4( ) { + uint8_t buf[1]; + uint32_t h, i, state[HASHSTATE]; + + + buf[0] = ~0; + for ( i = 0; i < HASHSTATE; ++i ) + state[i] = 1; + printf( "These should all be different\n" ); + for ( i = 0, h = 0; i < 8; ++i ) { + h = hashlittle( buf, 0, h ); + printf( "%2ld 0-byte strings, hash is %.8x\n", i, h ); + } +} + +void driver5( ) { + uint32_t b, c; + b = 0, c = 0, hashlittle2( "", 0, &c, &b ); + printf( "hash is %.8lx %.8lx\n", c, b ); /* deadbeef deadbeef */ + b = 0xdeadbeef, c = 0, hashlittle2( "", 0, &c, &b ); + printf( "hash is %.8lx %.8lx\n", c, b ); /* bd5b7dde deadbeef */ + b = 0xdeadbeef, c = 0xdeadbeef, hashlittle2( "", 0, &c, &b ); + printf( "hash is %.8lx %.8lx\n", c, b ); /* 9c093ccd bd5b7dde */ + b = 0, c = 0, hashlittle2( "Four score and seven years ago", 30, &c, &b ); + printf( "hash is %.8lx %.8lx\n", c, b ); /* 17770551 ce7226e6 */ + b = 1, c = 0, hashlittle2( "Four score and seven years ago", 30, &c, &b ); + printf( "hash is %.8lx %.8lx\n", c, b ); /* e3607cae bd371de4 */ + b = 0, c = 1, hashlittle2( "Four score and seven years ago", 30, &c, &b ); + printf( "hash is %.8lx %.8lx\n", c, b ); /* cd628161 6cbea4b3 */ + c = hashlittle( "Four score and seven years ago", 30, 0 ); + printf( "hash is %.8lx\n", c ); /* 17770551 */ + c = hashlittle( "Four score and seven years ago", 30, 1 ); + printf( "hash is %.8lx\n", c ); /* cd628161 */ +} + + +int main( ) { + driver1( ); /* test that the key is hashed: used for timings */ + driver2( ); /* test that whole key is hashed thoroughly */ + driver3( ); /* test that nothing but the key is hashed */ + driver4( ); /* test hashing multiple buffers (all buffers are null) */ + driver5( ); /* test the hash against known vectors */ + return 1; +} + +#endif /* SELF_TEST */ diff --git a/src/memory/lookup3.h b/src/memory/lookup3.h new file mode 100644 index 0000000..6df9447 --- /dev/null +++ b/src/memory/lookup3.h @@ -0,0 +1,16 @@ +/** + * lookup3.h + * + * Minimal header file wrapping Bob Jenkins' lookup3.c + * + * + * (c) 2019 Simon Brooke + * Public domain. + */ + +#ifndef __lookup3_h +#define __lookup3_h + +uint32_t hashword( const uint32_t * k, size_t length, uint32_t initval ); + +#endif diff --git a/src/memory/stack.c b/src/memory/stack.c index f91d896..4b70ed1 100644 --- a/src/memory/stack.c +++ b/src/memory/stack.c @@ -17,24 +17,32 @@ #include -#include "consspaceobject.h" -#include "conspage.h" +#include "memory/consspaceobject.h" +#include "memory/conspage.h" #include "debug.h" -#include "dump.h" -#include "lispops.h" -#include "print.h" -#include "stack.h" -#include "vectorspace.h" +#include "memory/dump.h" +#include "ops/lispops.h" +#include "io/print.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" -void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value) { - debug_printf(DEBUG_STACK, L"Setting register %d to ", reg); - debug_print_object(value, DEBUG_STACK); - debug_println(DEBUG_STACK); - frame->arg[reg++] = value; - inc_ref(value); - if (reg > frame->args) { - frame->args = reg; - } +/** + * set a register in a stack frame. Alwaye use this to do so, + * because that way we can be sure the inc_ref happens! + */ +void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ) { + debug_printf( DEBUG_STACK, L"Setting register %d to ", reg ); + debug_print_object( value, DEBUG_STACK ); + debug_println( DEBUG_STACK ); + dec_ref( frame->arg[reg] ); /* if there was anything in that slot + * previously other than NIL, we need to decrement it; + * NIL won't be decremented as it is locked. */ + frame->arg[reg] = value; + inc_ref( value ); + + if ( reg == frame->args ) { + frame->args++; + } } @@ -49,8 +57,8 @@ struct stack_frame *get_stack_frame( struct cons_pointer pointer ) { if ( vectorpointp( pointer ) && stackframep( vso ) ) { result = ( struct stack_frame * ) &( vso->payload ); - debug_printf( DEBUG_STACK, L"get_stack_frame: all good, returning %p\n", - result ); + debug_printf( DEBUG_STACK, + L"get_stack_frame: all good, returning %p\n", result ); } else { debug_print( L"get_stack_frame: fail, returning NULL\n", DEBUG_STACK ); } @@ -67,19 +75,14 @@ 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( STACKFRAMETAG, sizeof( struct stack_frame ) ); + make_vso( STACKFRAMETV, sizeof( struct stack_frame ) ); debug_dump_object( result, DEBUG_ALLOC ); -// debug_printf( DEBUG_STACK, -// L"make_empty_frame: got vector_space_object with size %lu, tag %4.4s\n", -// pointer_to_vso( result )->header.size, -// &pointer_to_vso( result )->header.tag.bytes ); - if ( !nilp( result ) ) { struct stack_frame *frame = get_stack_frame( result ); /* - * TODO: later, pop a frame off a free-list of stack frames + * \todo later, pop a frame off a free-list of stack frames */ frame->previous = previous; @@ -97,7 +100,7 @@ struct cons_pointer make_empty_frame( struct cons_pointer previous ) { } } debug_print( L"Leaving make_empty_frame\n", DEBUG_ALLOC ); - debug_dump_object( result, DEBUG_ALLOC); + debug_dump_object( result, DEBUG_ALLOC ); return result; } @@ -124,31 +127,33 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, } else { struct stack_frame *frame = get_stack_frame( result ); - while ( frame->args < args_in_frame && consp( args )) { + while ( frame->args < args_in_frame && consp( args ) ) { /* iterate down the arg list filling in the arg slots in the * frame. When there are no more slots, if there are still args, * stash them on more */ struct cons_space_object cell = pointer2cell( args ); /* - * TODO: if we were running on real massively parallel hardware, + * \todo if we were running on real massively parallel hardware, * each arg except the first should be handed off to another * processor to be evaled in parallel; but see notes here: * https://github.com/simon-brooke/post-scarcity/wiki/parallelism */ - struct cons_pointer val = eval_form(frame, result, cell.payload.cons.car, env); - if ( exceptionp( val ) ) { - result = val; - break; - } else { - debug_printf( DEBUG_STACK, L"Setting argument %d to ", frame->args); - debug_print_object(cell.payload.cons.car, DEBUG_STACK); - set_reg( frame, frame->args, val ); - } - - args = cell.payload.cons.cdr; + struct cons_pointer val = + eval_form( frame, result, cell.payload.cons.car, env ); + if ( exceptionp( val ) ) { + result = val; + break; + } else { + debug_printf( DEBUG_STACK, L"Setting argument %d to ", + frame->args ); + debug_print_object( cell.payload.cons.car, DEBUG_STACK ); + set_reg( frame, frame->args, val ); } + args = cell.payload.cons.cdr; + } + if ( !exceptionp( result ) ) { if ( consp( args ) ) { /* if we still have args, eval them and stick the values on `more` */ @@ -190,7 +195,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous, } else { struct stack_frame *frame = get_stack_frame( result ); - while ( frame->args < args_in_frame && !nilp( args )) { + while ( frame->args < args_in_frame && !nilp( args ) ) { /* iterate down the arg list filling in the arg slots in the * frame. When there are no more slots, if there are still args, * stash them on more */ @@ -218,16 +223,16 @@ struct cons_pointer make_special_frame( struct cons_pointer previous, */ void free_stack_frame( struct stack_frame *frame ) { /* - * TODO: later, push it back on the stack-frame freelist + * \todo later, push it back on the stack-frame freelist */ + debug_print( L"Entering free_stack_frame\n", DEBUG_ALLOC ); for ( int i = 0; i < args_in_frame; i++ ) { dec_ref( frame->arg[i] ); } if ( !nilp( frame->more ) ) { dec_ref( frame->more ); } - - free( frame ); + debug_print( L"Leaving free_stack_frame\n", DEBUG_ALLOC ); } @@ -236,35 +241,34 @@ void free_stack_frame( struct stack_frame *frame ) { * @param output the stream * @param frame_pointer the pointer to the frame */ -void dump_frame( FILE * output, struct cons_pointer frame_pointer ) { +void dump_frame( URL_FILE * output, struct cons_pointer frame_pointer ) { struct stack_frame *frame = get_stack_frame( frame_pointer ); if ( frame != NULL ) { - fwprintf( output, L"Stack frame with %d arguments:\n", frame->args); + url_fwprintf( output, L"Stack frame with %d arguments:\n", + frame->args ); for ( int arg = 0; arg < frame->args; arg++ ) { struct cons_space_object cell = pointer2cell( frame->arg[arg] ); - fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", arg, - cell.tag.bytes[0], - cell.tag.bytes[1], cell.tag.bytes[2], cell.tag.bytes[3], - cell.count ); + url_fwprintf( output, L"Arg %d:\t%c%c%c%c\tcount: %10u\tvalue: ", + arg, cell.tag.bytes[0], cell.tag.bytes[1], + cell.tag.bytes[2], cell.tag.bytes[3], cell.count ); print( output, frame->arg[arg] ); - fputws( L"\n", output ); + url_fputws( L"\n", output ); + } + if ( !nilp( frame->more ) ) { + url_fputws( L"More: \t", output ); + print( output, frame->more ); + url_fputws( L"\n", output ); } - if (!nilp(frame->more)) - { - fputws( L"More: \t", output ); - print( output, frame->more ); - fputws( L"\n", output ); - } } } -void dump_stack_trace( FILE * output, struct cons_pointer pointer ) { +void dump_stack_trace( URL_FILE * output, struct cons_pointer pointer ) { if ( exceptionp( pointer ) ) { - print( output, pointer2cell( pointer ).payload.exception.message ); - fputws( L"\n", output ); + print( output, pointer2cell( pointer ).payload.exception.payload ); + url_fputws( L"\n", output ); dump_stack_trace( output, pointer2cell( pointer ).payload.exception.frame ); } else { diff --git a/src/memory/stack.h b/src/memory/stack.h index 79cd1e2..f132c69 100644 --- a/src/memory/stack.h +++ b/src/memory/stack.h @@ -18,12 +18,12 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#ifndef __psse_stack_h +#define __psse_stack_h + #include "consspaceobject.h" #include "conspage.h" -#ifndef __stack_h -#define __stack_h - /** * macros for the tag of a stack frame. */ @@ -35,13 +35,7 @@ */ #define stackframep(vso)(((struct vector_space_object *)vso)->header.tag.value == STACKFRAMETV) -/** - * set a register in a stack frame. Alwaye use this macro to do so, - • because that way we can be sure the inc_ref happens! - */ -//#define set_reg(frame,register,value){frame->arg[register]=value; inc_ref(value);} - -void set_reg(struct stack_frame * frame, int reg, struct cons_pointer value); +void set_reg( struct stack_frame *frame, int reg, struct cons_pointer value ); struct stack_frame *get_stack_frame( struct cons_pointer pointer ); @@ -53,9 +47,9 @@ struct cons_pointer make_stack_frame( struct cons_pointer previous, void free_stack_frame( struct stack_frame *frame ); -void dump_frame( FILE * output, struct cons_pointer pointer ); +void dump_frame( URL_FILE * output, struct cons_pointer pointer ); -void dump_stack_trace( FILE * output, struct cons_pointer frame_pointer ); +void dump_stack_trace( URL_FILE * output, struct cons_pointer frame_pointer ); struct cons_pointer fetch_arg( struct stack_frame *frame, unsigned int n ); @@ -65,7 +59,7 @@ struct cons_pointer make_special_frame( struct cons_pointer previous, /* * struct stack_frame is defined in consspaceobject.h to break circularity - * TODO: refactor. + * \todo refactor. */ #endif diff --git a/src/memory/vectorspace.c b/src/memory/vectorspace.c index c30f120..4bbeb51 100644 --- a/src/memory/vectorspace.c +++ b/src/memory/vectorspace.c @@ -19,28 +19,41 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "vectorspace.h" +#include "memory/hashmap.h" +#include "memory/stack.h" +#include "memory/vectorspace.h" /** - * make a cons-space object which points to the vector space object + * Make a cons_space_object which points to the vector_space_object * with this `tag` at this `address`. - * NOTE that `tag` should be the vector-space tag of the particular type of - * vector-space object, NOT `VECTORPOINTTAG`. + * + * @address the address of the vector_space_object to point to. + * @tag the vector-space tag of the particular type of vector-space object, + * NOT `VECTORPOINTTV`. + * + * @return a cons_pointer to the object, or NIL if the object could not be + * allocated due to memory exhaustion. */ -struct cons_pointer make_vec_pointer( struct vector_space_object *address ) { +struct cons_pointer make_vec_pointer( struct vector_space_object *address, + uint32_t tag ) { debug_print( L"Entered make_vec_pointer\n", DEBUG_ALLOC ); - struct cons_pointer pointer = allocate_cell( VECTORPOINTTAG ); + struct cons_pointer pointer = allocate_cell( VECTORPOINTTV ); struct cons_space_object *cell = &pointer2cell( pointer ); + debug_printf( DEBUG_ALLOC, - L"make_vec_pointer: tag written, about to set pointer address to %p\n", - address ); + L"make_vec_pointer: tag written, about to set pointer address to %p\n", + address ); + cell->payload.vectorp.address = address; - debug_printf( DEBUG_ALLOC, L"make_vec_pointer: all good, returning pointer to %p\n", - cell->payload.vectorp.address ); + cell->payload.vectorp.tag.value = tag; + + debug_printf( DEBUG_ALLOC, + L"make_vec_pointer: all good, returning pointer to %p\n", + cell->payload.vectorp.address ); debug_dump_object( pointer, DEBUG_ALLOC ); @@ -48,13 +61,17 @@ struct cons_pointer make_vec_pointer( struct vector_space_object *address ) { } /** - * allocate a vector space object with this `payload_size` and `tag`, + * Allocate a vector space object with this `payload_size` and `tag`, * and return a `cons_pointer` which points to an object whigh points to it. - * NOTE that `tag` should be the vector-space tag of the particular type of - * vector-space object, NOT `VECTORPOINTTAG`. - * Returns NIL if the vector could not be allocated due to memory exhaustion. + * + * @tag the vector-space tag of the particular type of vector-space object, + * NOT `VECTORPOINTTAG`. + * @payload_size the size of the payload required, in bytes. + * + * @return a cons_pointer to the object, or NIL if the object could not be + * allocated due to memory exhaustion. */ -struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { +struct cons_pointer make_vso( uint32_t 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; @@ -66,11 +83,12 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { struct vector_space_object *vso = malloc( padded ); if ( vso != NULL ) { + memset( vso, 0, padded ); debug_printf( DEBUG_ALLOC, - L"make_vso: about to write tag '%s' into vso at %p\n", tag, - vso ); - strncpy( &vso->header.tag.bytes[0], tag, TAGLENGTH ); - result = make_vec_pointer( vso ); + L"make_vso: about to write tag '%4.4s' into vso at %p\n", + tag, vso ); + vso->header.tag.value = tag; + result = make_vec_pointer( vso, tag ); debug_dump_object( result, DEBUG_ALLOC ); vso->header.vecp = result; // memcpy(vso->header.vecp, result, sizeof(struct cons_pointer)); @@ -79,19 +97,55 @@ struct cons_pointer make_vso( char *tag, uint64_t payload_size ) { #ifdef DEBUG debug_printf( DEBUG_ALLOC, - L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n", - &vso->header.tag.bytes, total_size, vso->header.size, vso, - &vso->payload ); + L"Allocated vector-space object of type %4.4s, total size %ld, payload size %ld, at address %p, payload address %p\n", + &vso->header.tag.bytes, total_size, vso->header.size, + vso, &vso->payload ); if ( padded != total_size ) { debug_printf( DEBUG_ALLOC, L"\t\tPadded from %d to %d\n", - total_size, padded ); + total_size, padded ); } #endif } #ifdef DEBUG - debug_printf( DEBUG_ALLOC, L"make_vso: all good, returning pointer to %p\n", - pointer2cell( result ).payload.vectorp.address ); + debug_printf( DEBUG_ALLOC, + L"make_vso: all good, returning pointer to %p\n", + pointer2cell( result ).payload.vectorp.address ); #endif 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 1438d37..3265225 100644 --- a/src/memory/vectorspace.h +++ b/src/memory/vectorspace.h @@ -18,6 +18,7 @@ #include #include "consspaceobject.h" +#include "hashmap.h" #ifndef __vectorspace_h #define __vectorspace_h @@ -26,46 +27,95 @@ * part of the implementation structure of a namespace. */ #define HASHTAG "HASH" -#define HASHTV 0 +#define HASHTV 1213415752 + +#define hashmapp(conspoint)((check_tag(conspoint,HASHTV))) /* * 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 0 +#define NAMESPACETV 1347636558 + +#define namespacep(conspoint)(check_tag(conspoint,NAMESPACETV)) /* * a vector of cons pointers. */ #define VECTORTAG "VECT" -#define VECTORTV 0 +#define VECTORTV 1413694806 +#define vectorp(conspoint)(check_tag(conspoint,VECTORTV)) + +/** + * given a pointer to a vector space object, return the object. + */ #define pointer_to_vso(pointer)((vectorpointp(pointer)? (struct vector_space_object *) pointer2cell(pointer).payload.vectorp.address : (struct vector_space_object *) NULL)) -#define vso_get_vecp(vso)((vso->header.vecp)) -struct cons_pointer make_vso( char *tag, uint64_t payload_size ); +/** + * given a vector space object, return its canonical pointer. + */ +#define vso_get_vecp(vso)((((vector_space_object)vso)->header.vecp)) +struct cons_pointer make_vso( uint32_t tag, uint64_t payload_size ); + +void free_vso( struct cons_pointer pointer ); + +/** + * the header which forms the start of every vector space object. + */ struct vector_space_header { + /** the tag (type) of this vector-space object. */ union { - char bytes[TAGLENGTH]; /* the tag (type) of the - * vector-space object this cell - * points to, considered as bytes. - * NOTE that the vector space object - * should itself have the identical - * tag. */ - uint32_t value; /* the tag considered as a number */ + /** the tag considered as bytes. */ + char bytes[TAGLENGTH]; + /** the tag considered as a number */ + uint32_t value; } tag; - struct cons_pointer vecp; /* back pointer to the vector pointer - * which uniquely points to this vso */ - uint64_t size; /* the size of my payload, in bytes */ + /** back pointer to the vector pointer which uniquely points to this vso */ + struct cons_pointer vecp; + /** the size of my payload, in bytes */ + uint64_t size; }; +/** + * 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. + * + * \see stack_frame for an example payload; + * \see make_empty_frame for an example of how to initialise and use one. + */ struct vector_space_object { + /** the header of this object */ struct vector_space_header header; - char payload; /* we'll malloc `size` bytes for payload, - * `payload` is just the first of these. - * TODO: this is almost certainly not - * idiomatic C. */ + /** we'll malloc `size` bytes for payload, `payload` is just the first of these. + * \todo this is almost certainly not idiomatic C. */ + union { + /** the payload considered as bytes */ + char bytes; + struct hashmap_payload hashmap; + } payload; }; #endif diff --git a/src/ops/equal.c b/src/ops/equal.c index 0f0597c..39d80af 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -10,9 +10,11 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" -#include "integer.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "arith/integer.h" +#include "arith/peano.h" +#include "arith/ratio.h" /** * Shallow, and thus cheap, equality: true if these two objects are @@ -34,7 +36,6 @@ 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; - } /** @@ -62,39 +63,52 @@ 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, cell_b->payload.cons.cdr ); break; + 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.character == + cell_a->payload.string.hash == cell_b->payload.string.hash + && cell_a->payload.string.character == cell_b->payload.string.character - && ( equal( cell_a->payload.string.cdr, - cell_b->payload.string.cdr ) - || ( end_of_string( cell_a->payload.string.cdr ) - && end_of_string( cell_b->payload. - string.cdr ) ) ); + && + ( 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 = - cell_a->payload.integer.value == - cell_b->payload.integer.value; + ( cell_a->payload.integer.value == + cell_b->payload.integer.value ) && + equal( cell_a->payload.integer.more, + cell_b->payload.integer.more ); + break; + case RATIOTV: + result = equal_ratio_ratio( a, b ); break; case REALTV: { - double num_a = numeric_value( a ); - double num_b = numeric_value( b ); - double max = - fabs( num_a ) > - fabs( num_b ) ? fabs( num_a ) : fabs( num_b ); + double num_a = to_long_double( a ); + double num_b = to_long_double( b ); + double max = fabs( num_a ) > fabs( num_b ) + ? fabs( num_a ) + : fabs( num_b ); /* * not more different than one part in a million - close enough @@ -106,15 +120,21 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { result = false; break; } - - /* - * 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. - */ + } 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. + */ + return result; } diff --git a/src/ops/intern.c b/src/ops/intern.c index 27c745d..cd80612 100644 --- a/src/ops/intern.c +++ b/src/ops/intern.c @@ -19,15 +19,17 @@ #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/conspage.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "equal.h" -#include "lispops.h" -#include "print.h" +#include "ops/equal.h" +#include "memory/hashmap.h" +#include "ops/lispops.h" +// #include "print.h" /** - * The object list. What is added to this during system setup is 'global', that is, + * The global object list/or, to put it differently, the root namespace. + * What is added to this during system setup is 'global', that is, * visible to all sessions/threads. What is added during a session/thread is local to * that session/thread (because shallow binding). There must be some way for a user to * make the contents of their own environment persistent between threads but I don't @@ -50,29 +52,29 @@ struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer store ) { struct cons_pointer result = NIL; - if ( symbolp( key ) ) { + if ( symbolp( key ) || keywordp( key ) ) { for ( struct cons_pointer next = store; nilp( result ) && consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { struct cons_space_object entry = pointer2cell( pointer2cell( next ).payload.cons.car ); - debug_print( L"Internedp: checking whether `", DEBUG_ALLOC ); - debug_print_object( key, DEBUG_ALLOC ); - debug_print( L"` equals `", DEBUG_ALLOC ); - debug_print_object( entry.payload.cons.car, DEBUG_ALLOC ); - debug_print( L"`\n", DEBUG_ALLOC ); + debug_print( L"Internedp: checking whether `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"` equals `", DEBUG_BIND ); + debug_print_object( entry.payload.cons.car, DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND ); if ( equal( key, entry.payload.cons.car ) ) { result = entry.payload.cons.car; } } } else { - debug_print( L"`", DEBUG_ALLOC ); - debug_print_object( key, DEBUG_ALLOC ); - debug_print( L"` is a ", DEBUG_ALLOC ); - debug_print_object( c_type( key ), DEBUG_ALLOC ); - debug_print( L", not a SYMB", DEBUG_ALLOC ); + debug_print( L"`", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"` is a ", DEBUG_BIND ); + debug_print_object( c_type( key ), DEBUG_BIND ); + debug_print( L", not a KEYW or SYMB", DEBUG_BIND ); } return result; @@ -90,34 +92,76 @@ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store ) { struct cons_pointer result = NIL; - for ( struct cons_pointer next = store; - consp( next ); next = pointer2cell( next ).payload.cons.cdr ) { - struct cons_space_object entry = - pointer2cell( pointer2cell( next ).payload.cons.car ); + debug_print( L"c_assoc; key is `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"`\n", DEBUG_BIND ); - if ( equal( key, entry.payload.cons.car ) ) { - result = entry.payload.cons.cdr; - break; + if ( consp( store ) ) { + for ( struct cons_pointer next = store; + nilp( result ) && ( consp( next ) || hashmapp( next ) ); + next = pointer2cell( next ).payload.cons.cdr ) { + if ( consp( next ) ) { + struct cons_pointer entry_ptr = c_car( next ); + struct cons_space_object entry = pointer2cell( entry_ptr ); + + switch ( entry.tag.value ) { + case CONSTV: + if ( equal( key, entry.payload.cons.car ) ) { + result = entry.payload.cons.cdr; + } + break; + case VECTORPOINTTV: + result = hashmap_get( entry_ptr, key ); + break; + default: + throw_exception( c_string_to_lisp_string + ( L"Store entry is of unknown type" ), + NIL ); + } + } } + } else if ( hashmapp( store ) ) { + result = hashmap_get( store, key ); + } else if ( !nilp( store ) ) { + result = + throw_exception( c_string_to_lisp_string + ( L"Store is of unknown type" ), NIL ); } + debug_print( L"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 -bind( struct cons_pointer key, struct cons_pointer value, - struct cons_pointer store ) { - debug_print(L"Binding ", DEBUG_ALLOC); - debug_print_object(key, DEBUG_ALLOC); - debug_print(L" to ", DEBUG_ALLOC); - debug_print_object(value, DEBUG_ALLOC); - debug_println(DEBUG_ALLOC); + /** + * Return 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; - return make_cons( make_cons( key, value ), store ); + debug_print( L"set: binding `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"` to `", DEBUG_BIND ); + debug_print_object( value, DEBUG_BIND ); + debug_print( L"` in store ", DEBUG_BIND ); + debug_dump_object( store, DEBUG_BIND ); + debug_println( DEBUG_BIND ); + + if ( nilp( store ) || consp( store ) ) { + result = make_cons( make_cons( key, value ), store ); + } else if ( hashmapp( store ) ) { + result = hashmap_put( store, key, value ); + } + + debug_print( L"set returning ", DEBUG_BIND ); + debug_print_object( result, DEBUG_BIND ); + debug_println( DEBUG_BIND ); + + return result; } /** @@ -127,16 +171,25 @@ bind( struct cons_pointer key, struct cons_pointer value, */ struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ) { - debug_print( L"Entering deep_bind\n", DEBUG_ALLOC ); - debug_print( L"\tSetting ", DEBUG_ALLOC ); - debug_print_object( key, DEBUG_ALLOC ); - debug_print( L" to ", DEBUG_ALLOC ); - debug_print_object( value, DEBUG_ALLOC ); - debug_print( L"\n", DEBUG_ALLOC ); + debug_print( L"Entering deep_bind\n", DEBUG_BIND ); + struct cons_pointer old = oblist; - oblist = bind( key, value, oblist ); + debug_print( L"deep_bind: binding `", DEBUG_BIND ); + debug_print_object( key, DEBUG_BIND ); + debug_print( L"` to ", DEBUG_BIND ); + debug_print_object( value, DEBUG_BIND ); + debug_println( DEBUG_BIND ); - debug_print( L"Leaving deep_bind\n", DEBUG_ALLOC ); + oblist = set( key, value, oblist ); + + if ( consp( oblist ) ) { + inc_ref( oblist ); + dec_ref( old ); + } + + debug_print( L"deep_bind returning ", DEBUG_BIND ); + debug_print_object( oblist, DEBUG_BIND ); + debug_println( DEBUG_BIND ); return oblist; } @@ -154,7 +207,7 @@ intern( struct cons_pointer key, struct cons_pointer environment ) { /* * not currently bound */ - result = bind( key, NIL, environment ); + result = set( key, NIL, environment ); } return result; diff --git a/src/ops/intern.h b/src/ops/intern.h index e940daa..fa17563 100644 --- a/src/ops/intern.h +++ b/src/ops/intern.h @@ -1,14 +1,14 @@ -/** +/* * intern.h * * For now this implements an oblist and shallow binding; local environments can * be consed onto the front of the oblist. Later, this won't do; bindings will happen * in namespaces, which will probably be implemented as hash tables. - * + * * Doctrine is that cons cells are immutable, and life is a lot more simple if they are; * so when a symbol is rebound in the master oblist, what in fact we do is construct * a new oblist without the previous binding but with the new binding. Anything which, - * prior to this action, held a pointer to the old oblist (as all current threads' + * prior to this action, held a pointer to the old oblist (as all current threads' * environments must do) continues to hold a pointer to the old oblist, and consequently * doesn't see the change. This is probably good but does mean you cannot use bindings * on the oblist to signal between threads. @@ -22,42 +22,19 @@ extern struct cons_pointer oblist; -/** - * return the value associated with this key in this store. In the current - * implementation a store is just an assoc list, but in future it might be a - * namespace, a regularity or a homogeneity. - */ struct cons_pointer c_assoc( struct cons_pointer key, struct cons_pointer store ); -/** - * Return true if this key is present as a key in this enviroment, defaulting to - * the oblist if no environment is passed. - */ struct cons_pointer internedp( struct cons_pointer key, struct cons_pointer environment ); -/** - * Return a new key/value store containing all the key/value pairs in this store - * with this key/value pair added to the front. - */ -struct cons_pointer bind( struct cons_pointer key, - struct cons_pointer value, - struct cons_pointer store ); +struct cons_pointer set( struct cons_pointer key, + struct cons_pointer value, + struct cons_pointer store ); -/** - * Binds this key to this value in the global oblist, but doesn't affect the - * current environment. May not be useful except in bootstrapping (and even - * there it may not be especially useful). - */ struct cons_pointer deep_bind( struct cons_pointer key, struct cons_pointer value ); -/** - * Ensure that a canonical copy of this key is bound in this environment, and - * return that canonical copy. If there is currently no such binding, create one - * with the value NIL. - */ struct cons_pointer intern( struct cons_pointer key, struct cons_pointer environment ); diff --git a/src/ops/lispops.c b/src/ops/lispops.c index 82746e0..f9fb95a 100644 --- a/src/ops/lispops.c +++ b/src/ops/lispops.c @@ -24,54 +24,28 @@ #include #include -#include "consspaceobject.h" -#include "conspage.h" +#include "memory/consspaceobject.h" +#include "memory/conspage.h" #include "debug.h" -#include "dump.h" -#include "equal.h" -#include "integer.h" -#include "intern.h" -#include "lispops.h" -#include "print.h" -#include "read.h" -#include "stack.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" /* * 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); + * struct stack_frame* frame); * * and others I haven't thought of yet. */ -/** - * 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 ( consp( arg ) ) { - result = pointer2cell( arg ).payload.cons.car; - } - - return result; -} - -/** - * Implementation of cdr in C. If arg is not a cons, does not error but returns nil. - */ -struct cons_pointer c_cdr( struct cons_pointer arg ) { - struct cons_pointer result = NIL; - - if ( consp( arg ) || stringp( arg ) || symbolp( arg ) ) { - result = pointer2cell( arg ).payload.cons.cdr; - } - - return result; -} - /** * Useful building block; evaluate this single form in the context of this @@ -86,48 +60,121 @@ 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_dump_object( form, DEBUG_EVAL ); + debug_print_object( form, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); - struct cons_pointer result = NIL; - struct cons_pointer next_pointer = make_empty_frame( parent_pointer ); - inc_ref( next_pointer ); + 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 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 ); + if ( !exceptionp( result ) ) { + /* if we're returning an exception, we should NOT free the + * stack frame. Corollary is, when we free an exception, we + * should free all the frames it's holding on to. */ + dec_ref( next_pointer ); + } + } + break; } + debug_print( L"eval_form returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); + return result; } /** - * eval all the forms in this `list` in the context of this stack `frame` + * Evaluate all the forms in this `list` in the context of this stack `frame` * and this `env`, and return a list of their values. If the arg passed as - * `list` is not in fact a list, return nil. + * `list` is not in fact a list, return NIL. + * @param frame the stack frame. + * @param list the list of forms to be evaluated. + * @param env the evaluation environment. + * @return a list of the the results of evaluating the forms. */ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer list, struct cons_pointer env ) { - /* TODO: refactor. This runs up the C stack. */ - return consp( list ) ? - make_cons( eval_form( frame, frame_pointer, c_car( list ), env ), - eval_forms( frame, frame_pointer, c_cdr( list ), - env ) ) : NIL; + struct cons_pointer result = NIL; + + while ( consp( list ) ) { + result = + make_cons( eval_form( frame, frame_pointer, c_car( list ), env ), + result ); + list = c_cdr( list ); + } + + return 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). * - * (oblist) + * * (oblist) + * + * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the root namespace. */ struct cons_pointer lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -135,9 +182,8 @@ lisp_oblist( struct stack_frame *frame, struct cons_pointer frame_pointer, return oblist; } - /** - * used to construct the body for `lambda` and `nlambda` expressions. + * Used to construct the body for `lambda` and `nlambda` expressions. */ struct cons_pointer compose_body( struct stack_frame *frame ) { struct cons_pointer body = frame->more; @@ -157,10 +203,15 @@ struct cons_pointer compose_body( struct stack_frame *frame ) { } /** - * Construct an interpretable function. + * Construct an interpretable function. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs function will be created. + * + * (lambda args body) * * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. * @param env the environment in which it is to be intepreted. + * @return an interpretable function with these `args` and this `body`. */ struct cons_pointer lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -169,10 +220,15 @@ lisp_lambda( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * Construct an interpretable special form. + * Construct an interpretable special form. *NOTE* that if `args` is a single symbol + * rather than a list, a varargs special form will be created. + * + * (nlambda args body) * * @param frame the stack frame in which the expression is to be interpreted; + * @param frame_pointer a pointer to my stack_frame. * @param env the environment in which it is to be intepreted. + * @return an interpretable special form with these `args` and this `body`. */ struct cons_pointer lisp_nlambda( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -194,7 +250,8 @@ struct cons_pointer eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; - debug_print( L"eval_lambda called\n", DEBUG_EVAL ); + debug_print( L"eval_lambda called\n", DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); struct cons_pointer new_env = env; struct cons_pointer names = cell.payload.lambda.args; @@ -207,17 +264,20 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer name = c_car( names ); struct cons_pointer val = frame->arg[i]; - new_env = bind( name, val, new_env ); + new_env = set( name, val, new_env ); log_binding( name, val ); names = c_cdr( names ); } - /* TODO: if there's more than `args_in_frame` arguments, bind those too. */ + inc_ref( new_env ); + + /* \todo if there's more than `args_in_frame` arguments, bind those too. */ } else if ( symbolp( names ) ) { /* if `names` is a symbol, rather than a list of symbols, * then bind a list of the values of args to that symbol. */ - /* TODO: eval all the things in frame->more */ - struct cons_pointer vals = frame->more; + /* \todo eval all the things in frame->more */ + struct cons_pointer vals = + eval_forms( frame, frame_pointer, frame->more, env ); for ( int i = args_in_frame - 1; i >= 0; i-- ) { struct cons_pointer val = @@ -229,18 +289,36 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, } } - new_env = bind( names, vals, new_env ); + new_env = set( names, vals, new_env ); + inc_ref( new_env ); } while ( !nilp( body ) ) { struct cons_pointer sexpr = c_car( body ); body = c_cdr( body ); - debug_print( L"In lambda: ", DEBUG_LAMBDA ); + debug_print( L"In lambda: evaluating ", DEBUG_LAMBDA ); + debug_print_object( sexpr, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); + + /* if a result is not the terminal result in the lambda, it's a + * side effect, and needs to be GCed */ + if ( !nilp( result ) ) + dec_ref( result ); result = eval_form( frame, frame_pointer, sexpr, new_env ); + + if ( exceptionp( result ) ) { + break; + } } + dec_ref( new_env ); + + debug_print( L"eval_lambda returning: \n", DEBUG_LAMBDA ); + debug_print_object( result, DEBUG_LAMBDA ); + debug_println( DEBUG_LAMBDA ); + return result; } @@ -255,8 +333,8 @@ eval_lambda( struct cons_space_object cell, struct stack_frame *frame, struct cons_pointer 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; + debug_print( L"Entering c_apply\n", DEBUG_EVAL ); + struct cons_pointer result = NIL; struct cons_pointer fn_pointer = eval_form( frame, frame_pointer, c_car( frame->arg[0] ), env ); @@ -264,138 +342,157 @@ c_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( exceptionp( fn_pointer ) ) { result = fn_pointer; } else { - struct cons_space_object fn_cell = pointer2cell( fn_pointer ); - struct cons_pointer args = c_cdr( frame->arg[0] ); + struct cons_space_object fn_cell = pointer2cell( fn_pointer ); + struct cons_pointer args = c_cdr( frame->arg[0] ); - switch ( fn_cell.tag.value ) { - case EXCEPTIONTV: - /* 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 ); + switch ( fn_cell.tag.value ) { + case EXCEPTIONTV: + /* just pass exceptions straight back */ + result = fn_pointer; + break; - result = - ( *fn_cell.payload.function.executable ) ( next, - next_pointer, - env ); - dec_ref( next_pointer ); - } - } - 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 ) ) { + 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 ); + + result = + ( *fn_cell.payload.function.executable ) ( next, + next_pointer, + env ); dec_ref( next_pointer ); } } - } - 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 ); + break; + + case KEYTV: + 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 ); + } + } + } + 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; + } + 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 ); + } } - } - 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 ); + 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 ); + } } - } - 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 ); - } - } + 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 ); + } + } } - debug_print(L"c_apply: returning: ", DEBUG_EVAL); - debug_print_object(result, DEBUG_EVAL); - debug_println(DEBUG_EVAL); + debug_print( L"c_apply: returning: ", DEBUG_EVAL ); + debug_print_object( result, DEBUG_EVAL ); + debug_println( DEBUG_EVAL ); return result; } - /** - * Get the Lisp type of the single argument. - * @param pointer a pointer to the object whose type is requested. - * @return As a Lisp string, the tag of the object which is at that pointer. - */ -struct cons_pointer c_type( struct cons_pointer pointer ) { - struct cons_pointer result = NIL; - struct cons_space_object cell = pointer2cell( pointer ); - - for (int i = TAGLENGTH; i >= 0; i--) - { - result = make_string((wchar_t)cell.tag.bytes[i], result); - } - - return result; -} - - -/** - * (eval s_expr) + * Function; evaluate the expression which is the first argument in the frame; + * further arguments are ignored. * - * function. - * If s_expr is a number, NIL, or T, returns s_expr. - * If s_expr is an unprotected string, returns the value that s_expr is bound - * to in the evaluation environment (env). - * If s_expr is a list, expects the car to be something that evaluates to a - * function or special form. - * If a function, evaluates all the other top level elements in s_expr and - * passes them in a stack frame as arguments to the function. - * If a special form, passes the cdr of s_expr to the special form as argument. + * * (eval expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return + * * If `expression` is a number, string, `nil`, or `t`, returns `expression`. + * * If `expression` is a symbol, returns the value that expression is bound + * to in the evaluation environment (`env`). + * * If `expression` is a list, expects the car to be something that evaluates to a + * function or special form: + * * If a function, evaluates all the other top level elements in `expression` and + * passes them in a stack frame as arguments to the function; + * * If a special form, passes the cdr of expression to the special form as argument. + * @exception if `expression` is a symbol which is not bound in `env`. */ struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -408,9 +505,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: @@ -430,12 +525,9 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, } break; /* - * TODO: + * \todo * the Clojure practice of having a map serve in the function place of - * an s-expression is a good one and I should adopt it; also if the - * object is a consp it could be interpretable source code but in the - * long run I don't want an interpreter, and if I can get away without - * so much the better. + * an s-expression is a good one and I should adopt it; */ default: result = frame->arg[0]; @@ -450,19 +542,23 @@ lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (apply fn args) - * - * function. Apply the function which is the result of evaluating the - * first argoment to the list of arguments which is the result of evaluating + * Function; apply the function which is the result of evaluating the + * first argument to the list of values which is the result of evaluating * the second argument + * + * * (apply fn args) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return the result of applying `fn` to `args`. */ struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { -#ifdef DEBUG debug_print( L"Apply: ", DEBUG_EVAL ); - dump_frame( stderr, frame_pointer ); -#endif + debug_dump_object( frame_pointer, DEBUG_EVAL ); + set_reg( frame, 0, make_cons( frame->arg[0], frame->arg[1] ) ); set_reg( frame, 1, NIL ); @@ -476,11 +572,16 @@ lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (quote a) - * - * Special form - * Returns its argument (strictly first argument - only one is expected but + * Special form; + * returns its argument (strictly first argument - only one is expected but * this isn't at this stage checked) unevaluated. + * + * * (quote a) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `a`, unevaluated, */ struct cons_pointer lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -490,13 +591,19 @@ lisp_quote( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (set name value) - * (set name value namespace) - * - * Function. + * Function; + * binds the value of `name` in the `namespace` to value of `value`, altering + * the namespace in so doing. Retuns `value`. * `namespace` defaults to the oblist. - * Binds the value of `name` in the `namespace` to value of `value`, altering - * the namespace in so doing. `namespace` defaults to the value of `oblist`. + * \todo doesn't actually work yet for namespaces which are not the oblist. + * + * * (set name value) + * * (set name value namespace) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `value` */ struct cons_pointer lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -510,11 +617,11 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, result = frame->arg[1]; } else { result = - 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 ); + 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 ); } return result; @@ -522,20 +629,25 @@ lisp_set( struct stack_frame *frame, struct cons_pointer frame_pointer, /** - * (set! symbol value) - * (set! symbol value namespace) + * Special form; + * binds `symbol` in the `namespace` to value of `value`, altering + * the namespace in so doing, and returns value. `namespace` defaults to + * the value of `oblist`. + * \todo doesn't actually work yet for namespaces which are not the oblist. * - * Special form. - * `namespace` defaults to the oblist. - * Binds `symbol` in the `namespace` to value of `value`, altering - * the namespace in so doing. `namespace` defaults to the value of `oblist`. + * * (set! symbol value) + * * (set! symbol value namespace) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `value` */ struct cons_pointer lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; - struct cons_pointer namespace = - nilp( frame->arg[2] ) ? oblist : frame->arg[2]; + struct cons_pointer namespace = frame->arg[2]; if ( symbolp( frame->arg[0] ) ) { struct cons_pointer val = @@ -544,23 +656,38 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, result = val; } else { result = - 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 ); + 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 ); } return result; } /** - * (cons a b) - * - * Function. - * Returns a cell constructed from a and b. If a is of type string but its + * @return true if `arg` represents an end of string, else false. + * \todo candidate for moving to a memory/string.c file + */ +bool end_of_stringp( struct cons_pointer arg ) { + return nilp( arg ) || + ( stringp( arg ) && + pointer2cell( arg ).payload.string.character == ( wint_t ) '\0' ); +} + +/** + * Function; + * returns a cell constructed from a and b. If a is of type string but its * cdr is nill, and b is of type string, then returns a new string cell; * otherwise returns a new cons cell. + * + * * (cons a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return a new cons cell whose `car` is `a` and whose `cdr` is `b`. */ struct cons_pointer lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -572,7 +699,8 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, if ( nilp( car ) && nilp( cdr ) ) { return NIL; } else if ( stringp( car ) && stringp( cdr ) && - nilp( pointer2cell( car ).payload.string.cdr ) ) { + end_of_stringp( c_cdr( car ) ) ) { + // \todo check that car is of length 1 result = make_string( pointer2cell( car ).payload.string.character, cdr ); } else { @@ -583,58 +711,117 @@ lisp_cons( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (car s_expr) - * Returns the first item (head) of a sequence. Valid for cons cells, - * strings, and TODO read streams and other things which can be considered as sequences. + * Function; + * returns the first item (head) of a sequence. Valid for cons cells, + * strings, read streams and TODO other things which can be considered as sequences. + * + * * (car expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the first item (head) of `expression`. + * @exception if `expression` is not a sequence. */ struct cons_pointer lisp_car( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); - if ( consp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = cell.payload.cons.car; - } else if ( stringp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = make_string( cell.payload.string.character, NIL ); - } else { - struct cons_pointer message = - c_string_to_lisp_string( L"Attempt to take CAR of non sequence" ); - result = throw_exception( message, frame_pointer ); + switch ( cell.tag.value ) { + case CONSTV: + result = cell.payload.cons.car; + break; + case NILTV: + break; + case READTV: + result = + make_string( url_fgetwc( cell.payload.stream.stream ), NIL ); + break; + case STRINGTV: + result = make_string( cell.payload.string.character, NIL ); + break; + default: + result = + throw_exception( c_string_to_lisp_string + ( L"Attempt to take CAR of non sequence" ), + frame_pointer ); } return result; } /** - * (cdr s_expr) - * Returns the remainder of a sequence when the head is removed. Valid for cons cells, - * strings, and TODO read streams and other things which can be considered as sequences. + * Function; + * returns the remainder of a sequence when the head is removed. Valid for cons cells, + * strings, read streams and TODO other things which can be considered as sequences. + * *NOTE* that if the argument is an input stream, the first character is removed AND + * DISCARDED. + * + * * (cdr expression) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the remainder of `expression` when the head is removed. + * @exception if `expression` is not a sequence. */ struct cons_pointer lisp_cdr( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); - if ( consp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = cell.payload.cons.cdr; - } else if ( stringp( frame->arg[0] ) ) { - struct cons_space_object cell = pointer2cell( frame->arg[0] ); - result = cell.payload.string.cdr; - } else { - struct cons_pointer message = - c_string_to_lisp_string( L"Attempt to take CDR of non sequence" ); - result = throw_exception( message, frame_pointer ); + switch ( cell.tag.value ) { + case CONSTV: + result = cell.payload.cons.cdr; + break; + case NILTV: + break; + case READTV: + url_fgetwc( cell.payload.stream.stream ); + result = frame->arg[0]; + break; + case STRINGTV: + result = cell.payload.string.cdr; + break; + default: + result = + throw_exception( c_string_to_lisp_string + ( L"Attempt to take CDR of non sequence" ), + frame_pointer ); } return result; } /** - * (assoc key store) - * Returns the value associated with key in store, or NIL if not found. + * Function: return, as an integer, the length of the sequence indicated by + * the first argument, or zero if it is not a sequence. + * + * * (length any) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @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 ); +} + +/** + * Function; look up the value of a `key` in a `store`. + * + * * (assoc key store) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return the value associated with `key` in `store`, or `nil` if not found. */ struct cons_pointer lisp_assoc( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -642,9 +829,35 @@ 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] ); +} + /** - * (eq a b) - * Returns T if a and b are pointers to the same object, else NIL + * Function; are these two objects the same object? Shallow, cheap equality. + * + * * (eq a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `t` if `a` and `b` are pointers to the same object, else `nil`; */ struct cons_pointer lisp_eq( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -653,8 +866,14 @@ struct cons_pointer lisp_eq( struct stack_frame *frame, } /** - * (eq a b) - * Returns T if a and b are pointers to structurally identical objects, else NIL + * Function; are these two arguments identical? Deep, expensive equality. + * + * * (equal a b) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return `t` if `a` and `b` are recursively identical, else `nil`. */ struct cons_pointer lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -663,10 +882,17 @@ lisp_equal( struct stack_frame *frame, struct cons_pointer frame_pointer, } /** - * (read) - * (read read-stream) - * Read one complete lisp form and return it. If read-stream is specified and - * is a read stream, then read from that stream, else stdin. + * Function; read one complete lisp form and return it. If read-stream is specified and + * is a read stream, then read from that stream, else the stream which is the value of + * `*in*` in the environment. + * + * * (read) + * * (read read-stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return the expression read. */ struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -674,39 +900,60 @@ lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, #ifdef DEBUG debug_print( L"entering lisp_read\n", DEBUG_IO ); #endif - FILE *input = stdin; + URL_FILE *input; - if ( readp( frame->arg[0] ) ) { - input = pointer2cell( frame->arg[0] ).payload.stream.stream; + struct cons_pointer in_stream = readp( frame->arg[0] ) ? + frame->arg[0] : get_default_stream( true, env ); + + if ( readp( in_stream ) ) { + debug_print( L"lisp_read: setting input stream\n", DEBUG_IO ); + debug_dump_object( in_stream, DEBUG_IO ); + input = pointer2cell( in_stream ).payload.stream.stream; + inc_ref( in_stream ); + } else { + input = file_to_url_file( stdin ); } - struct cons_pointer result = read( frame, frame_pointer, input ); + struct cons_pointer result = read( frame, frame_pointer, env, input ); debug_print( L"lisp_read returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); + if ( readp( in_stream ) ) { + dec_ref( in_stream ); + } else { + free( input ); + } + + return result; } /** - * reverse a sequence. + * reverse a sequence (if it is a sequence); else return it unchanged. */ struct cons_pointer c_reverse( struct cons_pointer arg ) { struct cons_pointer result = NIL; - for ( struct cons_pointer p = arg; sequencep( p ); p = c_cdr( p ) ) { - struct cons_space_object o = pointer2cell( p ); - switch ( o.tag.value ) { - case CONSTV: - result = make_cons( o.payload.cons.car, result ); - break; - case STRINGTV: - result = make_string( o.payload.string.character, result ); - break; - case SYMBOLTV: - result = make_symbol( o.payload.string.character, result ); - break; + 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; + } } + } else { + result = arg; } return result; @@ -714,8 +961,14 @@ struct cons_pointer c_reverse( struct cons_pointer arg ) { /** - * (reverse sequence) - * Return a sequence like this sequence but with the members in the reverse order. + * Function; reverse the order of members in s sequence. + * + * * (reverse sequence) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return a sequence like this `sequence` but with the members in the reverse order. */ struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -723,25 +976,76 @@ 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; +} /** - * (print expr) - * (print expr write-stream) - * Print one complete lisp form and return NIL. If write-stream is specified and - * is a write stream, then print to that stream, else stdout. + * Function; print one complete lisp expression and return NIL. If write-stream is specified and + * is a write stream, then print to that stream, else the stream which is the value of + * `*out*` in the environment. + * + * * (print expr) + * * (print expr write-stream) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (from which the stream may be extracted). + * @return NIL. */ struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { debug_print( L"Entering print\n", DEBUG_IO ); struct cons_pointer result = NIL; - FILE *output = stdout; + URL_FILE *output; + struct cons_pointer out_stream = writep( frame->arg[1] ) ? + frame->arg[1] : get_default_stream( false, env ); - if ( writep( frame->arg[1] ) ) { + if ( writep( out_stream ) ) { debug_print( L"lisp_print: setting output stream\n", DEBUG_IO ); - debug_dump_object( frame->arg[1], DEBUG_IO ); - output = pointer2cell( frame->arg[1] ).payload.stream.stream; + debug_dump_object( out_stream, DEBUG_IO ); + output = pointer2cell( out_stream ).payload.stream.stream; + inc_ref( out_stream ); + } else { + output = file_to_url_file( stderr ); } + debug_print( L"lisp_print: about to print\n", DEBUG_IO ); debug_dump_object( frame->arg[0], DEBUG_IO ); @@ -750,15 +1054,25 @@ lisp_print( struct stack_frame *frame, struct cons_pointer frame_pointer, debug_print( L"lisp_print returning\n", DEBUG_IO ); debug_dump_object( result, DEBUG_IO ); + if ( writep( out_stream ) ) { + dec_ref( out_stream ); + } else { + free( output ); + } + return result; } /** - * Function: Get the Lisp type of the single argument. - * @param frame My stack frame. - * @param env My environment (ignored). - * @return As a Lisp string, the tag of the object which is the argument. + * Function: get the Lisp type of the single argument. + * + * * (type expression) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment (ignored). + * @return As a Lisp string, the tag of `expression`. */ struct cons_pointer lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -766,46 +1080,74 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, return c_type( frame->arg[0] ); } +/** + * Evaluate each of these expressions in this `env`ironment over this `frame`, + * returning only the value of the last. + */ +struct cons_pointer +c_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer expressions, struct cons_pointer env ) { + struct cons_pointer result = NIL; + + while ( consp( expressions ) ) { + struct cons_pointer r = result; + inc_ref( r ); + result = eval_form( frame, frame_pointer, c_car( expressions ), env ); + dec_ref( r ); + + expressions = exceptionp( result ) ? NIL : c_cdr( expressions ); + } + + return result; +} + /** - * (progn forms...) - * - * Special form; evaluate the forms which are listed in my arguments + * Special form; evaluate the expressions which are listed in my arguments * sequentially and return the value of the last. This function is called 'do' * in some dialects of Lisp. * - * @param frame My stack frame. - * @param env My environment (ignored). - * @return the value of the last form on the sequence which is my single + * * (progn expressions...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which expressions are evaluated. + * @return the value of the last `expression` of the sequence which is my single * argument. */ struct cons_pointer lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { - struct cons_pointer remaining = frame->more; struct cons_pointer result = NIL; for ( int i = 0; i < args_in_frame && !nilp( frame->arg[i] ); i++ ) { + struct cons_pointer r = result; + inc_ref( r ); + result = eval_form( frame, frame_pointer, frame->arg[i], env ); + + dec_ref( r ); } - while ( consp( remaining ) ) { - result = eval_form( frame, frame_pointer, c_car( remaining ), env ); - - remaining = c_cdr( remaining ); + if ( consp( frame->more ) ) { + result = c_progn( frame, frame_pointer, frame->more, env ); } return result; } /** - * Special form: conditional. Each arg is expected to be a list; if the first + * Special form: conditional. Each `clause` is expected to be a list; if the first * item in such a list evaluates to non-NIL, the remaining items in that list - * are evaluated in turn and the value of the last returned. If no arg (clause) + * are evaluated in turn and the value of the last returned. If no arg `clause` * has a first element which evaluates to non NIL, then NIL is returned. - * @param frame My stack frame. - * @param env My environment (ignored). - * @return the value of the last form of the first successful clause. + * + * * (cond clauses...) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which arguments will be evaluated. + * @return the value of the last expression of the first successful `clause`. */ struct cons_pointer lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, @@ -825,15 +1167,9 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, env ); if ( !nilp( result ) ) { - struct cons_pointer vals = - eval_forms( frame, frame_pointer, c_cdr( clause_pointer ), - env ); - - while ( consp( vals ) ) { - result = c_car( vals ); - vals = c_cdr( vals ); - } - + result = + c_progn( frame, frame_pointer, c_cdr( clause_pointer ), + env ); done = true; } } else if ( nilp( clause_pointer ) ) { @@ -844,7 +1180,7 @@ lisp_cond( struct stack_frame *frame, struct cons_pointer frame_pointer, frame_pointer ); } } - /* TODO: if there are more than 8 clauses we need to continue into the + /* \todo if there are more than 8 clauses we need to continue into the * remainder */ return result; @@ -879,9 +1215,18 @@ throw_exception( struct cons_pointer message, } /** - * (exception ) + * Function; create an exception. Exceptions are special in as much as if an + * exception is created in the binding of the arguments of any function, the + * function will return the exception rather than whatever else it would + * normally return. A function which detects a problem it cannot resolve + * *should* return an exception. * - * Function. Returns an exception whose message is this `message`, and whose + * * (exception message frame) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which arguments will be evaluated. + * @return areturns an exception whose message is this `message`, and whose * stack frame is the parent stack frame when the function is invoked. * `message` does not have to be a string but should be something intelligible * which can be read. @@ -891,6 +1236,363 @@ struct cons_pointer lisp_exception( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ) { struct cons_pointer message = frame->arg[0]; - return exceptionp( message ) ? message : make_exception( message, - frame->previous ); + return exceptionp( message ) ? message : throw_exception( message, + frame->previous ); } + +/** + * Function: the read/eval/print loop. + * + * * (repl) + * * (repl prompt) + * * (repl prompt input_stream output_stream) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment in which epressions will be evaluated. + * @return the value of the last expression read. + */ +struct cons_pointer lisp_repl( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer expr = NIL; + + debug_printf(DEBUG_REPL, L"Entering new inner REPL\n"); + + struct cons_pointer input = get_default_stream( true, env ); + struct cons_pointer output = get_default_stream( false, env ); + struct cons_pointer prompt_name = c_string_to_lisp_symbol( L"*prompt*" ); + struct cons_pointer old_oblist = oblist; + struct cons_pointer new_env = env; + + inc_ref( env ); + + if (truep(frame->arg[0])) { + new_env = set( prompt_name, frame->arg[0], new_env); + } + if (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 + * eval as parent, and it in turn would have the stack frame for + * print as parent. + */ + while ( readp( input ) && writep( output ) + && !url_feof( pointer2cell( input ).payload.stream.stream ) ) { + /* OK, here's a really subtle problem: because lists are immutable, anything + * bound in the oblist subsequent to this function being invoked isn't in the + * environment. So, for example, changes to *prompt* or *log* made in the oblist + * are not visible. So copy changes made in the oblist into the enviroment. + * \todo the whole process of resolving symbol values needs to be revisited + * when we get onto namespaces. */ + /* 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; + + while ( !nilp( cursor ) && !eq( cursor, old_oblist ) ) { + struct cons_pointer old_new_env = new_env; + debug_print + ( L"lisp_repl: copying new oblist binding into REPL environment:\n", + DEBUG_REPL ); + debug_print_object( c_car( cursor ), DEBUG_REPL ); + debug_println( DEBUG_REPL ); + + new_env = make_cons( c_car( cursor ), new_env ); + inc_ref( new_env ); + dec_ref( old_new_env ); + cursor = c_cdr( cursor ); + } + old_oblist = oblist; + } + + println( os ); + + struct cons_pointer prompt = c_assoc( prompt_name, new_env ); + if ( !nilp( prompt ) ) { + print( os, prompt ); + } + + expr = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, + new_env ); + inc_ref( expr ); + + if ( exceptionp( expr ) + && url_feof( pointer2cell( input ).payload.stream.stream ) ) { + /* suppress printing end of stream exception */ + break; + } + + println( os ); + + print( os, eval_form( frame, frame_pointer, expr, new_env ) ); + + dec_ref( expr ); + } + + dec_ref( input ); + dec_ref( output ); + dec_ref( prompt_name ); + dec_ref( env ); + + debug_printf(DEBUG_REPL, L"Leaving inner repl\n"); + + return expr; +} + +/** + * Function. return the source code of the object which is its first argument, + * if it is an executable and has source code. + * + * * (source object) + * + * @param frame my stack frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env the environment (ignored). + * @return the source of the `object` indicated, if it is a function, a lambda, + * an nlambda, or a spcial form; else `nil`. + */ +struct cons_pointer lisp_source( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); + struct cons_pointer source_key = c_string_to_lisp_keyword( L"source" ); + switch ( cell.tag.value ) { + case FUNCTIONTV: + result = c_assoc( source_key, cell.payload.function.meta ); + break; + case SPECIALTV: + result = c_assoc( source_key, cell.payload.special.meta ); + break; + case LAMBDATV: + result = make_cons( c_string_to_lisp_symbol( L"lambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + break; + case NLAMBDATV: + result = make_cons( c_string_to_lisp_symbol( L"nlambda" ), + make_cons( cell.payload.lambda.args, + cell.payload.lambda.body ) ); + break; + } + // \todo suffers from premature GC, and I can't see why! + inc_ref( result ); + + return result; +} + +/** + * 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 + */ +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 ) ); + + for ( int a = frame->args - 2; a >= 0; a-- ) { + result = c_append( fetch_arg( frame, a ), result ); + } + + return result; +} + +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 a1dee81..da1f27e 100644 --- a/src/ops/lispops.h +++ b/src/ops/lispops.h @@ -19,29 +19,22 @@ * Licensed under GPL version 2.0, or, at your option, any later version. */ +#ifndef __psse_lispops_h +#define __psse_lispops_h + /* * utilities */ -/** - * Get the Lisp type of the single argument. - * @param pointer a pointer to the object whose type is requested. - * @return As a Lisp string, the tag of the object which is at that pointer. - */ -struct cons_pointer c_type( struct cons_pointer pointer ); - -/** - * 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 ); - -/** - * Implementation of cdr in C. If arg is not a cons, does not error but returns nil. - */ -struct cons_pointer c_cdr( struct cons_pointer arg ); +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. @@ -65,7 +58,6 @@ struct cons_pointer eval_forms( struct stack_frame *frame, struct cons_pointer list, struct cons_pointer env ); - /* * special forms */ @@ -76,17 +68,21 @@ struct cons_pointer lisp_apply( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); -struct cons_pointer -lisp_oblist( struct stack_frame *frame, struct cons_pointer 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_set( 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_shriek( 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 ); /** * Construct an interpretable function. @@ -98,16 +94,18 @@ lisp_set_shriek( struct stack_frame *frame, struct cons_pointer frame_pointer, 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 ); /** * 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, @@ -116,6 +114,9 @@ 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 ); @@ -125,9 +126,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_assoc( 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_eq( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); @@ -140,19 +141,22 @@ struct cons_pointer lisp_print( struct stack_frame *frame, struct cons_pointer lisp_read( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +struct cons_pointer lisp_repl( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); struct cons_pointer lisp_reverse( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); + /** * Function: Get the Lisp type of the single argument. * @param frame My stack frame. * @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 @@ -164,9 +168,9 @@ lisp_type( struct stack_frame *frame, struct cons_pointer frame_pointer, * @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 @@ -177,19 +181,46 @@ lisp_progn( struct stack_frame *frame, struct cons_pointer frame_pointer, * @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_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 new file mode 100644 index 0000000..6ccada6 --- /dev/null +++ b/src/ops/loop.c @@ -0,0 +1,50 @@ +/* + * 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 new file mode 100644 index 0000000..27714a8 --- /dev/null +++ b/src/ops/loop.h @@ -0,0 +1,10 @@ +/* + * 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 new file mode 100644 index 0000000..f00824f --- /dev/null +++ b/src/ops/meta.c @@ -0,0 +1,45 @@ +/* + * meta.c + * + * Get metadata from a cell which has it. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include "memory/conspage.h" +#include "debug.h" + +/** + * Function: get metadata describing my first argument. + * + * * (metadata any) + * + * @return a pointer to the metadata of my first argument, or nil if none. + */ +struct cons_pointer lisp_metadata( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ) { + debug_print( L"lisp_metadata: entered\n", DEBUG_EVAL ); + debug_dump_object( frame->arg[0], DEBUG_EVAL ); + struct cons_pointer result = NIL; + struct cons_space_object cell = pointer2cell( frame->arg[0] ); + + switch ( cell.tag.value ) { + case FUNCTIONTV: + result = cell.payload.function.meta; + break; + case SPECIALTV: + result = cell.payload.special.meta; + break; + case READTV: + case WRITETV: + result = cell.payload.stream.meta; + break; + } + + return make_cons( make_cons( c_string_to_lisp_keyword( L"type" ), + c_type( frame->arg[0] ) ), result ); + +// return result; +} diff --git a/src/ops/meta.h b/src/ops/meta.h new file mode 100644 index 0000000..f441a50 --- /dev/null +++ b/src/ops/meta.h @@ -0,0 +1,18 @@ +/* + * meta.h + * + * Get metadata from a cell which has it. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_meta_h +#define __psse_meta_h + + +struct cons_pointer lisp_metadata( struct stack_frame *frame, + struct cons_pointer frame_pointer, + struct cons_pointer env ); + +#endif diff --git a/src/ops/print.c b/src/ops/print.c deleted file mode 100644 index 49adca7..0000000 --- a/src/ops/print.c +++ /dev/null @@ -1,210 +0,0 @@ -/* - * print.c - * - * First pass at a printer, for bootstrapping. - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#include "conspage.h" -#include "consspaceobject.h" -#include "integer.h" -#include "stack.h" -#include "print.h" - -/** - * Whether or not we colorise output. - * TODO: this should be a Lisp symbol binding, not a C variable. - */ -int print_use_colours = 0; - -/** - * print all the characters in the symbol or string indicated by `pointer` - * onto this `output`; if `pointer` does not indicate a string or symbol, - * don't print anything but just return. - */ -void print_string_contents( FILE * output, struct cons_pointer pointer ) { - while ( stringp( pointer ) || symbolp( pointer ) ) { - struct cons_space_object *cell = &pointer2cell( pointer ); - wchar_t c = cell->payload.string.character; - - if ( c != '\0' ) { - fputwc( c, output ); - } - pointer = cell->payload.string.cdr; - } -} - -/** - * print all the characters in the string indicated by `pointer` onto - * the stream at this `output`, prepending and appending double quote - * characters. - */ -void print_string( FILE * output, struct cons_pointer pointer ) { - fputwc( btowc( '"' ), output ); - print_string_contents( output, pointer ); - fputwc( btowc( '"' ), output ); -} - -/** - * Print a single list cell (cons cell) indicated by `pointer` to the - * stream indicated by `output`. if `initial_space` is `true`, prepend - * a space character. - */ -void -print_list_contents( FILE * output, struct cons_pointer pointer, - bool initial_space ) { - struct cons_space_object *cell = &pointer2cell( pointer ); - - switch ( cell->tag.value ) { - case CONSTV: - if ( initial_space ) { - fputwc( btowc( ' ' ), output ); - } - print( output, cell->payload.cons.car ); - - print_list_contents( output, cell->payload.cons.cdr, true ); - break; - case NILTV: - break; - default: - fwprintf( output, L" . " ); - print( output, pointer ); - } -} - -void print_list( FILE * output, struct cons_pointer pointer ) { - if ( print_use_colours ) { - fwprintf( output, L"%s(%s", "\x1B[31m", "\x1B[39m" ); - } else { - fputws( L"(", output ); - }; - - print_list_contents( output, pointer, false ); - if ( print_use_colours ) { - fwprintf( output, L"%s)%s", "\x1B[31m", "\x1B[39m" ); - } else { - fputws( L")", output ); - } - -} - -/** - * Print the cons-space object indicated by `pointer` to the stream indicated - * by `output`. - */ -struct cons_pointer print( FILE * output, struct cons_pointer pointer ) { - struct cons_space_object cell = pointer2cell( pointer ); - char *buffer; - - /* - * Because tags have values as well as bytes, this if ... else if - * statement can ultimately be replaced by a switch, which will be neater. - */ - switch ( cell.tag.value ) { - case CONSTV: - print_list( output, pointer ); - break; - case EXCEPTIONTV: - fwprintf( output, L"\n%sException: ", - print_use_colours ? "\x1B[31m" : "" ); - dump_stack_trace( output, pointer ); - break; - case FUNCTIONTV: - fwprintf( output, L"(Function)" ); - break; - case INTEGERTV: - if ( print_use_colours ) { - fputws( L"\x1B[34m", output ); - } - fwprintf( output, L"%ld%", cell.payload.integer.value ); - break; - case LAMBDATV: - print( output, make_cons( c_string_to_lisp_symbol( L"lambda" ), - make_cons( cell.payload.lambda.args, - cell.payload.lambda. - body ) ) ); - break; - case NILTV: - fwprintf( output, L"nil" ); - break; - case NLAMBDATV: - print( output, make_cons( c_string_to_lisp_symbol( L"nlambda" ), - make_cons( cell.payload.lambda.args, - cell.payload.lambda. - body ) ) ); - break; - case RATIOTV: - print( output, cell.payload.ratio.dividend ); - fputws( L"/", output ); - print( output, cell.payload.ratio.divisor ); - break; - case READTV: - fwprintf( output, L"(Input stream)" ); - break; - case REALTV: - /* TODO: using the C heap is a bad plan because it will fragment. - * As soon as I have working vector space I'll use a special purpose - * vector space object */ - buffer = ( char * ) malloc( 24 ); - memset( buffer, 0, 24 ); - /* format it really long, then clear the trailing zeros */ - sprintf( buffer, "%-.23Lg", cell.payload.real.value ); - if ( strchr( buffer, '.' ) != NULL ) { - for ( int i = strlen( buffer ) - 1; buffer[i] == '0'; i-- ) { - buffer[i] = '\0'; - } - } - if ( print_use_colours ) { - fputws( L"\x1B[34m", output ); - } - fwprintf( output, L"%s", buffer ); - free( buffer ); - break; - case STRINGTV: - if ( print_use_colours ) { - fputws( L"\x1B[36m", output ); - } - print_string( output, pointer ); - break; - case SYMBOLTV: - if ( print_use_colours ) { - fputws( L"\x1B[1;33m", output ); - } - print_string_contents( output, pointer ); - break; - case SPECIALTV: - fwprintf( output, L"(Special form)" ); - break; - case TRUETV: - fwprintf( output, L"t" ); - break; - case WRITETV: - fwprintf( output, L"(Output stream)" ); - break; - default: - fwprintf( stderr, - L"%sError: Unrecognised tag value %d (%c%c%c%c)\n", - print_use_colours ? "\x1B[31m" : "", - cell.tag.value, cell.tag.bytes[0], cell.tag.bytes[1], - cell.tag.bytes[2], cell.tag.bytes[3] ); - break; - } - - if ( print_use_colours ) { - fputws( L"\x1B[39m", output ); - } - - return pointer; -} diff --git a/src/ops/read.c b/src/ops/read.c deleted file mode 100644 index a9b1ffe..0000000 --- a/src/ops/read.c +++ /dev/null @@ -1,342 +0,0 @@ -/* - * read.c - * - * First pass at a reader, for bootstrapping. - * - * - * (c) 2017 Simon Brooke - * Licensed under GPL version 2.0, or, at your option, any later version. - */ - -#include -#include -#include -/* - * wide characters - */ -#include -#include - -#include "consspaceobject.h" -#include "debug.h" -#include "dump.h" -#include "integer.h" -#include "intern.h" -#include "lispops.h" -#include "print.h" -#include "ratio.h" -#include "read.h" -#include "real.h" -#include "vectorspace.h" - -/* - * for the time being things which may be read are: strings numbers - either - * 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, - struct cons_pointer frame_pointer, - FILE * input, wint_t initial, - bool seen_period ); -struct cons_pointer read_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, FILE * input, - wint_t initial ); -struct cons_pointer read_string( FILE * input, wint_t initial ); -struct cons_pointer read_symbol( FILE * input, wint_t initial ); - -/** - * quote reader macro in C (!) - */ -struct cons_pointer c_quote( struct cons_pointer arg ) { - return make_cons( c_string_to_lisp_symbol( L"quote" ), - make_cons( arg, NIL ) ); -} - -/** - * 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 - * representation. - */ -struct cons_pointer read_continuation( struct stack_frame *frame, - struct cons_pointer frame_pointer, - FILE * input, wint_t initial ) { - debug_print( L"entering read_continuation\n", DEBUG_IO ); - struct cons_pointer result = NIL; - - wint_t c; - - for ( c = initial; - c == '\0' || iswblank( c ) || iswcntrl( c ); c = fgetwc( input ) ); - - if ( feof( input ) ) { - result = - throw_exception( c_string_to_lisp_string - ( L"End of file while reading" ), frame_pointer ); - } else { - switch ( c ) { - case ';': - for ( c = fgetwc( input ); c != '\n'; c = fgetwc( input ) ); - /* skip all characters from semi-colon to the end of the line */ - break; - case EOF: - result = throw_exception( c_string_to_lisp_string - ( L"End of input while reading" ), - frame_pointer ); - break; - case '\'': - result = - c_quote( read_continuation - ( frame, frame_pointer, input, - fgetwc( input ) ) ); - break; - case '(': - result = - read_list( frame, frame_pointer, input, fgetwc( input ) ); - break; - case '"': - result = read_string( input, fgetwc( input ) ); - break; - case '-':{ - wint_t next = fgetwc( input ); - ungetwc( next, input ); - if ( iswdigit( next ) ) { - result = - read_number( frame, frame_pointer, input, c, - false ); - } else { - result = read_symbol( input, c ); - } - } - break; - case '.': - { - wint_t next = fgetwc( input ); - if ( iswdigit( next ) ) { - ungetwc( next, input ); - result = - read_number( frame, frame_pointer, input, c, - true ); - } else if ( iswblank( next ) ) { - /* dotted pair. TODO: this isn't right, we - * really need to backtrack up a level. */ - result = - read_continuation( frame, frame_pointer, input, - fgetwc( input ) ); - } else { - read_symbol( input, c ); - } - } - break; - default: - if ( iswdigit( c ) ) { - result = - read_number( frame, frame_pointer, input, c, false ); - } else if ( iswprint( c ) ) { - result = read_symbol( input, c ); - } else { - result = - throw_exception( make_cons( c_string_to_lisp_string - ( L"Unrecognised start of input character" ), - make_string( c, NIL ) ), - frame_pointer ); - } - break; - } - } - debug_print( L"read_continuation returning\n", DEBUG_IO ); - debug_dump_object( result, DEBUG_IO ); - - return result; -} - -/** - * read a number from this input stream, given this initial character. - * TODO: to be able to read bignums, we need to read the number from the - * input stream into a Lisp string, and then convert it to a number. - */ -struct cons_pointer read_number( struct stack_frame *frame, - struct cons_pointer frame_pointer, - FILE * input, - wint_t initial, bool seen_period ) { - debug_print( L"entering read_number\n", DEBUG_IO ); - struct cons_pointer result = NIL; - int64_t accumulator = 0; - int64_t dividend = 0; - int places_of_decimals = 0; - wint_t c; - bool negative = initial == btowc( '-' ); - - if ( negative ) { - initial = fgetwc( input ); - } - - debug_printf( DEBUG_IO, L"read_number starting '%c' (%d)\n", initial, initial ); - - for ( c = initial; iswdigit( c ) - || c == btowc( '.' ) || c == btowc( '/' ); c = fgetwc( input ) ) { - if ( c == btowc( '.' ) ) { - if ( seen_period || dividend != 0 ) { - return throw_exception( c_string_to_lisp_string - ( L"Malformed number: too many periods" ), - frame_pointer ); - } else { - seen_period = true; - } - } else if ( c == btowc( '/' ) ) { - if ( seen_period || dividend > 0 ) { - return throw_exception( c_string_to_lisp_string - ( L"Malformed number: dividend of rational must be integer" ), - frame_pointer ); - } else { - dividend = negative ? 0 - accumulator : accumulator; - - accumulator = 0; - } - } else { - accumulator = accumulator * 10 + ( ( int ) c - ( int ) '0' ); - - debug_printf( DEBUG_IO, - L"Added character %c, accumulator now %ld\n", - c, accumulator ); - - if ( seen_period ) { - places_of_decimals++; - } - } - } - - /* - * push back the character read which was not a digit - */ - ungetwc( c, input ); - if ( seen_period ) { - long double rv = ( long double ) - ( accumulator / pow( 10, places_of_decimals ) ); - if ( negative ) { - rv = 0 - rv; - } - result = make_real( rv ); - } else if ( dividend != 0 ) { - result = - make_ratio( frame_pointer, make_integer( dividend ), - make_integer( accumulator ) ); - } else { - if ( negative ) { - accumulator = 0 - accumulator; - } - result = make_integer( accumulator ); - } - - debug_print( L"read_number returning\n", DEBUG_IO ); - debug_dump_object( result, DEBUG_IO ); - - return result; -} - -/** - * Read a list from this input stream, which no longer contains the opening - * left parenthesis. - */ -struct cons_pointer read_list( struct stack_frame *frame, - struct cons_pointer frame_pointer, - FILE * input, wint_t initial ) { - struct cons_pointer result = NIL; - if ( initial != ')' ) { - debug_printf( DEBUG_IO, - L"read_list starting '%C' (%d)\n", initial, initial ); - struct cons_pointer car = - read_continuation( frame, frame_pointer, input, - initial ); - result = - make_cons( car, - read_list( frame, frame_pointer, input, - fgetwc( input ) ) ); - } else { - debug_print( L"End of list detected\n", DEBUG_IO ); - } - - 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 - * not contain a double quote character (unless escaped), or one not - * so delimited in which case it may not contain whitespace (unless escaped) - * but may contain a double quote character (probably not a good idea!) - */ -struct cons_pointer read_string( FILE * input, wint_t initial ) { - struct cons_pointer cdr = NIL; - struct cons_pointer result; - switch ( initial ) { - case '\0': - result = make_string( initial, NIL ); - break; - case '"': - result = make_string( '\0', NIL ); - break; - default: - result = - make_string( initial, read_string( input, fgetwc( input ) ) ); - break; - } - - return result; -} - -struct cons_pointer read_symbol( FILE * input, wint_t initial ) { - struct cons_pointer cdr = NIL; - struct cons_pointer result; - switch ( initial ) { - case '\0': - result = make_symbol( initial, NIL ); - break; - case '"': - /* - * THIS IS NOT A GOOD IDEA, but is legal - */ - result = - make_symbol( initial, read_symbol( input, fgetwc( input ) ) ); - break; - case ')': - /* - * unquoted strings may not include right-parenthesis - */ - result = make_symbol( '\0', NIL ); - /* - * push back the character read - */ - ungetwc( initial, input ); - break; - default: - if ( iswprint( initial ) - && !iswblank( initial ) ) { - result = - make_symbol( initial, - read_symbol( input, fgetwc( input ) ) ); - } else { - result = NIL; - /* - * push back the character read - */ - ungetwc( initial, input ); - } - break; - } - - debug_print( L"read_symbol returning\n", DEBUG_IO ); - debug_dump_object( result, DEBUG_IO ); - - return result; -} - -/** - * Read the next object on this input stream and return a cons_pointer to it. - */ -struct cons_pointer read( struct - stack_frame - *frame, struct cons_pointer frame_pointer, - FILE * input ) { - return read_continuation( frame, frame_pointer, input, fgetwc( input ) ); -} diff --git a/src/repl.c b/src/repl.c index e0170b6..bef08b1 100644 --- a/src/repl.c +++ b/src/repl.c @@ -11,107 +11,32 @@ #include #include -#include "conspage.h" -#include "consspaceobject.h" +#include "memory/consspaceobject.h" #include "debug.h" -#include "intern.h" -#include "lispops.h" -#include "read.h" -#include "print.h" -#include "stack.h" +#include "ops/intern.h" +#include "ops/lispops.h" +#include "memory/stack.h" -/* TODO: this is subtly wrong. If we were evaluating - * (print (eval (read))) - * then the stack frame for read would have the stack frame for - * eval as parent, and it in turn would have the stack frame for - * print as parent. - */ - /** - * Dummy up a Lisp read call with its own stack frame. + * The read/eval/print loop. */ -struct cons_pointer repl_read( struct cons_pointer stream_pointer ) { - struct cons_pointer result = NIL; - debug_print( L"Entered repl_read\n", DEBUG_REPL ); - struct cons_pointer frame_pointer = make_stack_frame( NIL, make_cons(stream_pointer, NIL), oblist ); - debug_print( L"repl_read: got stack_frame pointer\n", DEBUG_REPL ); - debug_dump_object( frame_pointer, DEBUG_REPL ); +void repl( ) { + debug_print( L"Entered repl\n", DEBUG_REPL ); + + struct cons_pointer env = + consp( oblist ) ? oblist : make_cons( oblist, NIL ); + + /* bottom of stack */ + struct cons_pointer frame_pointer = make_stack_frame( NIL, NIL, env ); + if ( !nilp( frame_pointer ) ) { inc_ref( frame_pointer ); - result = lisp_read( get_stack_frame( frame_pointer ), frame_pointer, oblist ); + + lisp_repl( get_stack_frame( frame_pointer ), frame_pointer, env ); + dec_ref( frame_pointer ); } - debug_print( L"repl_read: returning\n", DEBUG_REPL ); - debug_dump_object( result, DEBUG_REPL ); - return result; -} - -/** - * Dummy up a Lisp eval call with its own stack frame. - */ -struct cons_pointer repl_eval( struct cons_pointer input ) { - debug_print( L"Entered repl_eval\n", DEBUG_REPL ); - struct cons_pointer result = NIL; - - result = eval_form( NULL, NIL, input, oblist ); - - debug_print( L"repl_eval: returning\n", DEBUG_REPL ); - debug_dump_object( result, DEBUG_REPL ); - - return result; -} - -/** - * Dummy up a Lisp print call with its own stack frame. - */ -struct cons_pointer repl_print( struct cons_pointer stream_pointer, - struct cons_pointer value ) { - debug_print( L"Entered repl_print\n", DEBUG_REPL ); - debug_dump_object( value, DEBUG_REPL ); - struct cons_pointer result = - print( pointer2cell( stream_pointer ).payload.stream.stream, value ); - debug_print( L"repl_print: returning\n", DEBUG_REPL ); - debug_dump_object( result, DEBUG_REPL ); - - return result; -} - -/** - * The read/eval/print loop - * @param in_stream the stream to read from; - * @param out_stream the stream to write to; - * @param err_stream the stream to send errors to; - * @param show_prompt true if prompts should be shown. - */ -void -repl( FILE * in_stream, FILE * out_stream, FILE * error_stream, - bool show_prompt ) { - debug_print( L"Entered repl\n", DEBUG_REPL ); - struct cons_pointer input_stream = make_read_stream( in_stream ); - inc_ref( input_stream ); - - struct cons_pointer output_stream = make_write_stream( out_stream ); - inc_ref( output_stream ); - while ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) { - if ( show_prompt ) { - fwprintf( out_stream, L"\n:: " ); - } - - struct cons_pointer input = repl_read( input_stream ); - inc_ref( input ); - - if ( exceptionp( input ) ) { - /* suppress the end-of-stream exception */ - if ( !feof( pointer2cell( input_stream ).payload.stream.stream ) ) { - repl_print( output_stream, input ); - } - break; - } else { - repl_print( output_stream, repl_eval( input ) ); - } - dec_ref( input ); - } - debug_print( L"Leaving repl\n", DEBUG_REPL ); + debug_print( L"Leaving repl\n", DEBUG_REPL ); } diff --git a/src/repl.h b/src/repl.h index 1a7b0e9..8ff8b19 100644 --- a/src/repl.h +++ b/src/repl.h @@ -20,13 +20,8 @@ extern "C" { /** * The read/eval/print loop - * @param in_stream the stream to read from; - * @param out_stream the stream to write to; - * @param err_stream the stream to send errors to; - * @param show_prompt true if prompts should be shown. */ - void repl( FILE * in_stream, FILE * out_stream, - FILE * error_stream, bool show_prompt ); + void repl( ); #ifdef __cplusplus } diff --git a/src/time/psse_time.c b/src/time/psse_time.c new file mode 100644 index 0000000..06c1b58 --- /dev/null +++ b/src/time/psse_time.c @@ -0,0 +1,109 @@ +/* + * psse_time.c + * + * Bare bones of PSSE time. See issue #16. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include +/* + * wide characters + */ +#include +#include + +#include "memory/conspage.h" +#include "memory/consspaceobject.h" +#include "arith/integer.h" +#include "time/psse_time.h" +#define _GNU_SOURCE + +#define seconds_per_year 31557600L + +/** + * 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 ) ); + +/** + * 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 result = 0; + + 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 ); + } + } + + return result; +} + +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_space_object *cell = &pointer2cell( pointer ); + + if ( integerp( integer_or_nil ) ) { + cell->payload.time.value = + pointer2cell( integer_or_nil ).payload.integer.value; + } else { + cell->payload.time.value = unix_time_to_lisp_time( time( NULL ) ); + } + + return pointer; +} + +/** + * Function; return a time representation of the first argument in the frame; + * further arguments are ignored. + * + * * (time integer_or_nil) + * + * @param frame my stack_frame. + * @param frame_pointer a pointer to my stack_frame. + * @param env my environment. + * @return a lisp time; if `integer_or_nil` is an integer, return a time which + * 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] ); +} + +/** + * This is temporary, for bootstrapping. + */ +struct cons_pointer time_to_string( struct cons_pointer pointer ) { + struct cons_pointer result = NIL; + 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]; + + 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 new file mode 100644 index 0000000..f2afdd2 --- /dev/null +++ b/src/time/psse_time.h @@ -0,0 +1,21 @@ +/* + * psse_time.h + * + * Bare bones of PSSE time. See issue #16. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_time_h +#define __psse_time_h + +#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 ); + +#endif diff --git a/src/utils.c b/src/utils.c new file mode 100644 index 0000000..9919dbe --- /dev/null +++ b/src/utils.c @@ -0,0 +1,33 @@ +/* + * utils.c + * + * little generally useful functions which aren't in any way special to PSSE. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#include +#include +#include + + +int index_of( char c, const char *s ) { + int i; + + for ( i = 0; s[i] != c && s[i] != 0; i++ ); + + return s[i] == c ? i : -1; +} + +char *trim( char *s ) { + int i; + + for ( i = strlen( s ); ( isblank( s[i] ) || iscntrl( s[i] ) ) && i >= 0; + i-- ) { + s[i] = '\0'; + } + for ( i = 0; s[i] != '\0' && ( isblank( s[i] ) || iscntrl( s[i] ) ); i++ ); + + return ( char * ) &s[i]; +} diff --git a/src/utils.h b/src/utils.h new file mode 100644 index 0000000..456e4d0 --- /dev/null +++ b/src/utils.h @@ -0,0 +1,17 @@ +/* + * utils.h + * + * little generally useful functions which aren't in any way special to PSSE. + * + * (c) 2019 Simon Brooke + * Licensed under GPL version 2.0, or, at your option, any later version. + */ + +#ifndef __psse_utils_h +#define __psse_utils_h + +int index_of( char c, const char *s ); + +char *trim( char *s ); + +#endif diff --git a/src/version.h b/src/version.h index 96fb98e..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.4" +#define VERSION "0.0.5-SNAPSHOT" diff --git a/unit-tests/add.sh b/unit-tests/add.sh old mode 100644 new mode 100755 index 4516808..2802c3a --- a/unit-tests/add.sh +++ b/unit-tests/add.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(add 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(add 2 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='5.5' -actual=`echo "(add 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(add 2.5 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -24,7 +24,7 @@ else fi expected='1/4' -actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 3/14 1/28)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -36,7 +36,7 @@ fi # (+ integer ratio) should be ratio expected='25/4' -actual=`echo "(+ 6 1/4)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 6 1/4)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -48,7 +48,7 @@ fi # (+ ratio integer) should be ratio expected='25/4' -actual=`echo "(+ 1/4 6)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 1/4 6)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/append.sh b/unit-tests/append.sh new file mode 100755 index 0000000..0f6fb30 --- /dev/null +++ b/unit-tests/append.sh @@ -0,0 +1,24 @@ +#!/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/apply.sh b/unit-tests/apply.sh old mode 100644 new mode 100755 index 3483fb0..811fdae --- a/unit-tests/apply.sh +++ b/unit-tests/apply.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='1' -actual=`echo "(apply 'add '(1))"| target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(apply 'add '(1))"| target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/bignum-add.sh b/unit-tests/bignum-add.sh new file mode 100755 index 0000000..7bbb41e --- /dev/null +++ b/unit-tests/bignum-add.sh @@ -0,0 +1,228 @@ +#!/bin/bash + +##################################################################### +# add two large numbers, not actally bignums to produce a smallnum +# (right on the boundary) +a=1152921504606846975 +b=1 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking no bignum was created: " +grep -v 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# add two numbers, not actally bignums to produce a bignum +# (just over the boundary) +a='1152921504606846976' +b=1 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + + +##################################################################### +# add a bignum and a smallnum to produce a bignum +# (just over the boundary) +a='1152921504606846977' +b=1 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# add a smallnum and a bignum to produce a bignum +# (just over the boundary) +a=1 +b=1152921504606846977 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + + +##################################################################### +# add two bignums to produce a bignum +a=10000000000000000000 +b=10000000000000000000 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + + +##################################################################### +# add a smallnum and a two-cell bignum to produce a three-cell bignum +# (just over the boundary) +a=1 +b=1329227995784915872903807060280344576 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + + +##################################################################### +# This currently fails: +# (= (+ 1 3064991081731777716716694054300618367237478244367204352) +# 3064991081731777716716694054300618367237478244367204353) +a=1 +b=3064991081731777716716694054300618367237478244367204352 +c=`echo "$a + $b" | bc` +expected='t' +output=`echo "(= (+ $a $b) $c)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "adding $a to $b: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking a bignum was created: " +grep 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi diff --git a/unit-tests/bignum-expt.sh b/unit-tests/bignum-expt.sh new file mode 100755 index 0000000..ab9cb24 --- /dev/null +++ b/unit-tests/bignum-expt.sh @@ -0,0 +1,135 @@ +#!/bin/bash + +##################################################################### +# last 'smallnum' value: +# sbcl calculates (expt 2 59) => 576460752303423488 +expected='576460752303423488' + +output=`target/psse < 1152921504606846976 +expected='1152921504606846976' + +output=`target/psse < 2305843009213693952 +expected='2305843009213693952' + +output=`target/psse < 18446744073709551616 +expected='18446744073709551616' + +output=`target/psse < 36893488147419103232 +expected='36893488147419103232' + +output=`target/psse <psse.log` + +actual=`echo $output |\ + sed 's/\,//g' |\ + sed 's/[^0-9]*\([0-9]*\).*/\1/'` + +echo -n "printing $expected: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + +##################################################################### +# right on the boundary +expected='1152921504606846976' +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + sed 's/\,//g' |\ + sed 's/[^0-9]*\([0-9]*\).*/\1/'` + +echo -n "printing $expected: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + +##################################################################### +# definitely a bignum +expected='1152921504606846977' +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + sed 's/\,//g' |\ + sed 's/[^0-9]*\([0-9]*\).*/\1/'` + +echo -n "printing $expected: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + +# Currently failing from here on, but it's failing in read because of +# the multiply bug. We know printing blows up at the 3 cell boundary +# because `lisp/scratchpad2.lisp` constructs a 3 cell bignum by +# repeated addition. +##################################################################### +# Just on the three cell boundary +expected='1329227995784915872903807060280344576' +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + sed 's/\,//g' |\ + sed 's/[^0-9]*\([0-9]*\).*/\1/'` + +echo -n "printing $expected: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', \n got '${actual}'" + exit 1 +fi + +exit 0 + +##################################################################### +# definitely a three cell bignum +expected='1329227995784915872903807060280344577' +output=`echo "(progn (print $expected) nil)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + sed 's/\,//g' |\ + sed 's/[^0-9]*\([0-9]*\).*/\1/'` + +echo -n "printing $expected: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +exit 0 diff --git a/unit-tests/bignum-subtract.sh b/unit-tests/bignum-subtract.sh new file mode 100755 index 0000000..9342913 --- /dev/null +++ b/unit-tests/bignum-subtract.sh @@ -0,0 +1,116 @@ +#!/bin/bash + +##################################################################### +# subtract a smallnum from a smallnum to produce a smallnum +# (right on the boundary) +a=1152921504606846976 +b=1 +expected='1152921504606846975' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +echo -n "checking no bignum was created: " +grep -v 'BIGNUM!' psse.log > /dev/null +if [ $? -eq "0" ] +then + echo "OK" +else + echo "Fail" + exit 1 +fi + +##################################################################### +# subtract a smallnum from a bignum to produce a smallnum +# (just over the boundary) +a='1152921504606846977' +b=1 +expected='1152921504606846976' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# subtract a smallnum from a bignum to produce a smallnum +a='1152921504606846978' +b=1 +expected='1152921504606846977' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + +##################################################################### +# subtract a bignum from a smallnum to produce a negstive smallnum +# (just over the boundary) +a=1 +b=1152921504606846977 +expected='-1152921504606846976' +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# subtract a bignum from a bignum to produce a bignum +a=20000000000000000000 +b=10000000000000000000 +expected=10000000000000000000 +output=`echo "(- $a $b)" | target/psse -v 2 2>psse.log` + +actual=`echo $output |\ + tail -1 |\ + sed 's/\,//g'` + +echo -n "subtracting $b from $a: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + diff --git a/unit-tests/bignum.sh b/unit-tests/bignum.sh new file mode 100755 index 0000000..aa29143 --- /dev/null +++ b/unit-tests/bignum.sh @@ -0,0 +1,14 @@ +#!/bin/bash + +expected='1,152,921,504,606,846,976' +# 1,152,921,504,606,846,975 is the largest single cell positive integer; +# consequently 1,152,921,504,606,846,976 is the first two cell positive integer. +actual=`echo '(+ 1,152,921,504,606,846,975 1)' | target/psse -v 68 2>bignum.log | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/complex-list.sh b/unit-tests/complex-list.sh old mode 100644 new mode 100755 index d3728d8..3e84d79 --- a/unit-tests/complex-list.sh +++ b/unit-tests/complex-list.sh @@ -1,7 +1,7 @@ #!/bin/bash -expected='(1 2 3 ("Fred") nil 77354)' -actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse 2> /dev/null | head -2 | tail -1` +expected='(1 2 3 ("Fred") nil 77,354)' +actual=`echo "'(1 2 3 (\"Fred\") () 77354)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/cond.sh b/unit-tests/cond.sh old mode 100644 new mode 100755 index 227f9b3..ab2e2f0 --- a/unit-tests/cond.sh +++ b/unit-tests/cond.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(cond ((equal 2 2) 5))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(cond ((equal 2 2) 5))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='"should"' -actual=`echo "(cond ((equal 2 3) \"shouldn't\")(t \"should\"))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(cond ((equal 2 3) \"shouldn't\")(t \"should\"))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/empty-list.sh b/unit-tests/empty-list.sh old mode 100644 new mode 100755 index 1e24452..8f0f702 --- a/unit-tests/empty-list.sh +++ b/unit-tests/empty-list.sh @@ -1,5 +1,5 @@ #!/bin/bash -# +# # File: empty-list.sh.bash # Author: simon # @@ -7,7 +7,7 @@ # expected=nil -actual=`echo "'()" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'()" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/empty-string.sh b/unit-tests/empty-string.sh old mode 100644 new mode 100755 index 340fd1b..a1e5baa --- a/unit-tests/empty-string.sh +++ b/unit-tests/empty-string.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="\"\"" -actual=`echo '""' | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo '""' | target/psse | tail -1` if [ "$expected" = "$actual" ] then diff --git a/unit-tests/eval-integer.sh b/unit-tests/eval-integer.sh old mode 100644 new mode 100755 index addc133..1aadb39 --- a/unit-tests/eval-integer.sh +++ b/unit-tests/eval-integer.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(eval 5)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(eval 5)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/eval-quote-sexpr.sh b/unit-tests/eval-quote-sexpr.sh old mode 100644 new mode 100755 index eea16ec..d83bbe8 --- a/unit-tests/eval-quote-sexpr.sh +++ b/unit-tests/eval-quote-sexpr.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(eval '(add 2 3))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(eval '(add 2 3))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/eval-quote-symbol.sh b/unit-tests/eval-quote-symbol.sh old mode 100644 new mode 100755 index 5eca83d..e977461 --- a/unit-tests/eval-quote-symbol.sh +++ b/unit-tests/eval-quote-symbol.sh @@ -1,7 +1,7 @@ #!/bin/bash -expected='(Special form)' -actual=`echo "(eval 'cond)" | target/psse 2> /dev/null | head -2 | tail -1` +expected='' +actual=`echo "(eval 'cond)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/eval-real.sh b/unit-tests/eval-real.sh old mode 100644 new mode 100755 index 8832719..3aa16d7 --- a/unit-tests/eval-real.sh +++ b/unit-tests/eval-real.sh @@ -5,12 +5,11 @@ expected='5.05' actual=`echo "(eval 5.05)" |\ target/psse 2> /dev/null |\ sed 's/0*$//' |\ - head -2 |\ tail -1` +# one part in a million is close enough... outcome=`echo "sqrt((${expected} - ${actual})^2) < 0.0000001" | bc` - if [ "${outcome}" = "1" ] then echo "OK" diff --git a/unit-tests/eval-string.sh b/unit-tests/eval-string.sh old mode 100644 new mode 100755 index 4b8dc8e..90f6f2c --- a/unit-tests/eval-string.sh +++ b/unit-tests/eval-string.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"5"' -actual=`echo '(eval "5")' | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo '(eval "5")' | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/fred.sh b/unit-tests/fred.sh old mode 100644 new mode 100755 index 427c60d..8e3d513 --- a/unit-tests/fred.sh +++ b/unit-tests/fred.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"Fred"' -actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo ${expected} | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/integer-allocation.sh b/unit-tests/integer-allocation.sh old mode 100644 new mode 100755 index 5d07d90..b25bef3 --- a/unit-tests/integer-allocation.sh +++ b/unit-tests/integer-allocation.sh @@ -1,8 +1,8 @@ #!/bin/bash value=354 -expected="Integer cell: value ${value}" -echo ${value} | target/psse -d 2>&1 | grep "${expected}" > /dev/null +expected="(${value} \"INTR\")" +echo "(set! x $value)(list x (type x))" | target/psse 2>&1 | grep "${expected}" > /dev/null if [ $? -eq 0 ] then diff --git a/unit-tests/integer.sh b/unit-tests/integer.sh old mode 100644 new mode 100755 index 41b2da3..18ae66e --- a/unit-tests/integer.sh +++ b/unit-tests/integer.sh @@ -1,7 +1,7 @@ #!/bin/bash -expected="354" -actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` +expected='354' +actual=`echo ${expected} | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/intepreter.sh b/unit-tests/intepreter.sh old mode 100644 new mode 100755 index 9eb2a06..6f23fc9 --- a/unit-tests/intepreter.sh +++ b/unit-tests/intepreter.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='6' -actual=`echo "(apply '(lambda (x y z) (/ (* y z) x)) '(2 3 4))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(apply '(lambda (x y z) (/ (* y z) x)) '(2 3 4))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/lambda.sh b/unit-tests/lambda.sh old mode 100644 new mode 100755 index c1197e0..9695e6c --- a/unit-tests/lambda.sh +++ b/unit-tests/lambda.sh @@ -1,10 +1,11 @@ #!/bin/bash -expected='(lambda (l) l)(1 2 3 4 5 6 7 8 9 10)' -actual=`target/psse 2>/dev/null </dev/null < /dev/null | head -2 | tail -1` +actual=`echo "(+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +# check that all the args are actually being evaluated... +expected="120" +actual=`echo "(+ (+ 0 1) (+ 0 2) (+ 0 3) (+ 0 4) (+ 0 5) (+ 0 6) (+ 0 7) (+ 0 8) (+ 0 9) (+ 0 10) (+ 0 11) (+ 0 12) (+ 0 13) (+ 0 14 ) (+ 0 15))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then echo "OK" - exit 0 else echo "Fail: expected '${expected}', got '${actual}'" exit 1 diff --git a/unit-tests/map.sh b/unit-tests/map.sh new file mode 100755 index 0000000..65dc182 --- /dev/null +++ b/unit-tests/map.sh @@ -0,0 +1,90 @@ +#!/bin/bash + +##################################################################### +# Create an empty map using map notation +expected='{}' +actual=`echo "$expected" | target/psse | tail -1` + +echo -n "Empty map using compact map notation: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# Create an empty map using make-map +expected='{}' +actual=`echo "(hashmap)" | target/psse | tail -1` + +echo -n "Empty map using (make-map): " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# Create a map using map notation: order of keys in output is not +# significant at this stage, but in the long term should be sorted +# alphanumerically +expected='{:one 1, :two 2, :three 3}' +actual=`echo "{:one 1 :two 2 :three 3}" | target/psse | tail -1` + +echo -n "Map using map notation: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# Create a map using make-map: order of keys in output is not +# significant at this stage, but in the long term should be sorted +# alphanumerically +expected='{:one 1, :two 2, :three 3}' +actual=`echo "(hashmap nil nil '((:one . 1)(:two . 2)(:three . 3)))" | target/psse | tail -1` + +echo -n "Map using (hashmap): " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# Keyword in function position +expected='2' +actual=`echo "(:two {:one 1 :two 2 :three 3})" | target/psse | tail -1` + +echo -n "Keyword in function position: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + +##################################################################### +# Map in function position +expected='2' +actual=`echo "({:one 1 :two 2 :three 3} :two)" | target/psse | tail -1` + +echo -n "Map in function position: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/multiply.sh b/unit-tests/multiply.sh old mode 100644 new mode 100755 index 0675a6f..94b19f6 --- a/unit-tests/multiply.sh +++ b/unit-tests/multiply.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='6' -actual=`echo "(multiply 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(multiply 2 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='7.5' -actual=`echo "(multiply 2.5 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(multiply 2.5 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/nil.sh b/unit-tests/nil.sh old mode 100644 new mode 100755 index de4ef57..fcbf530 --- a/unit-tests/nil.sh +++ b/unit-tests/nil.sh @@ -1,7 +1,7 @@ #!/bin/bash expected=nil -actual=`echo 'nil' | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo 'nil' | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/nlambda.sh b/unit-tests/nlambda.sh old mode 100644 new mode 100755 index f267527..68f0447 --- a/unit-tests/nlambda.sh +++ b/unit-tests/nlambda.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='a' -actual=`echo "((nlambda (x) x) a)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "((nlambda (x) x) a)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/path-notation.sh b/unit-tests/path-notation.sh new file mode 100755 index 0000000..a6cb669 --- /dev/null +++ b/unit-tests/path-notation.sh @@ -0,0 +1,31 @@ +#!/bin/bash + +##################################################################### +# Create a path from root using compact path notation +expected='(-> oblist :users :simon :functions (quote assoc))' +actual=`echo "'/:users:simon:functions/assoc" | target/psse | tail -1` + +echo -n "Path from root (oblist) using compact notation: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +##################################################################### +# Create a path from the current session using compact path notation +expected='(-> session :input-stream)' +actual=`echo "'$:input-stream" | target/psse | tail -1` + +echo -n "Path from current session using compact notation: " +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + + diff --git a/unit-tests/progn.sh b/unit-tests/progn.sh old mode 100644 new mode 100755 index 017646b..352c87a --- a/unit-tests/progn.sh +++ b/unit-tests/progn.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='5' -actual=`echo "(progn (add 2 3))" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(progn (add 2 3))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -12,7 +12,7 @@ else fi expected='"foo"' -actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(progn (add 2.5 3) \"foo\")" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quote.sh b/unit-tests/quote.sh old mode 100644 new mode 100755 index bded011..78d4ce5 --- a/unit-tests/quote.sh +++ b/unit-tests/quote.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='Fred' -actual=`echo "'Fred" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'Fred" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/quoted-list.sh b/unit-tests/quoted-list.sh old mode 100644 new mode 100755 index 24480c6..f69cd75 --- a/unit-tests/quoted-list.sh +++ b/unit-tests/quoted-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='(123 (4 (5 nil)) Fred)' -actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'(123 (4 (5 ())) Fred)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/ratio-addition.sh b/unit-tests/ratio-addition.sh old mode 100644 new mode 100755 index f57d0b0..ba93c5d --- a/unit-tests/ratio-addition.sh +++ b/unit-tests/ratio-addition.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='1/4' -actual=`echo "(+ 3/14 1/28)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(+ 3/14 1/28)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/recursion.sh b/unit-tests/recursion.sh old mode 100644 new mode 100755 index a49154b..6b5be2d --- a/unit-tests/recursion.sh +++ b/unit-tests/recursion.sh @@ -1,7 +1,7 @@ #!/bin/bash -expected='nil3628800' -actual=`target/psse 2>/dev/null </dev/null </dev/null < /dev/null | head -2 | tail -1` +actual=`echo '(reverse "The quick brown fox jumped over the lazy dog")' | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -11,8 +11,8 @@ else exit 1 fi -expected='(1024 512 256 128 64 32 16 8 4 2)' -actual=`echo "(reverse '(2 4 8 16 32 64 128 256 512 1024))" | target/psse 2> /dev/null | head -2 | tail -1` +expected='(1,024 512 256 128 64 32 16 8 4 2)' +actual=`echo "(reverse '(2 4 8 16 32 64 128 256 512 1024))" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then @@ -23,7 +23,7 @@ else fi expected='esrever' -actual=`echo "(reverse 'reverse)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "(reverse 'reverse)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/simple-list.sh b/unit-tests/simple-list.sh old mode 100644 new mode 100755 index 60492b9..daf3db2 --- a/unit-tests/simple-list.sh +++ b/unit-tests/simple-list.sh @@ -1,7 +1,7 @@ #!/bin/bash expected="(1 2 3)" -actual=`echo "'(1 2 3)" | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo "'(1 2 3)" | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/slurp.sh b/unit-tests/slurp.sh new file mode 100755 index 0000000..0a9bc7c --- /dev/null +++ b/unit-tests/slurp.sh @@ -0,0 +1,16 @@ +#!/bin/bash + +tmp=hi.$$ +echo "Hello, there." > ${tmp} +expected='"Hello, there.' +actual=`echo "(slurp (open \"${tmp}\"))" | target/psse | tail -2 | head -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" + rm ${tmp} + exit 0 +else + echo "Fail: expected '$expected', got '$actual'" + exit 1 +fi diff --git a/unit-tests/string-allocation.sh b/unit-tests/string-allocation.sh old mode 100644 new mode 100755 diff --git a/unit-tests/string-cons.sh b/unit-tests/string-cons.sh new file mode 100755 index 0000000..0ea0a71 --- /dev/null +++ b/unit-tests/string-cons.sh @@ -0,0 +1,25 @@ +#!/bin/bash + +# We should be able to cons a single character string onto the front of a string +expected='"Test"' +actual=`echo '(cons "T" "est")' | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +# But if the first argument has more than one character, we should get a dotted pair +expected='("Test" . "pass")' +actual=`echo '(cons "Test" "pass")' | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/string-with-spaces.sh b/unit-tests/string-with-spaces.sh old mode 100644 new mode 100755 index 384cc9f..0f0f6d0 --- a/unit-tests/string-with-spaces.sh +++ b/unit-tests/string-with-spaces.sh @@ -1,7 +1,7 @@ #!/bin/bash expected='"Strings should be able to include spaces (and other stuff)!"' -actual=`echo ${expected} | target/psse 2> /dev/null | head -2 | tail -1` +actual=`echo ${expected} | target/psse | tail -1` if [ "${expected}" = "${actual}" ] then diff --git a/unit-tests/try.sh b/unit-tests/try.sh new file mode 100755 index 0000000..a6d529c --- /dev/null +++ b/unit-tests/try.sh @@ -0,0 +1,45 @@ +#!/bin/bash + +expected=':foo' +actual=`echo "(try ((+ 2 (/ 1 'a))) (:foo))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='4' +actual=`echo "(try ((+ 2 (/ 1 'a))) ((+ 2 2)))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='8' +actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch (* 2 2 2)))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi + +expected='' +actual=`echo "(try (:body (+ 2 (/ 1 'a))) (:catch *exception*))" | target/psse | tail -1` + +if [ "${expected}" = "${actual}" ] +then + echo "OK" +else + echo "Fail: expected '${expected}', got '${actual}'" + exit 1 +fi diff --git a/unit-tests/varargs.sh b/unit-tests/varargs.sh old mode 100644 new mode 100755 index 6c31163..27bac3e --- a/unit-tests/varargs.sh +++ b/unit-tests/varargs.sh @@ -1,10 +1,7 @@ #!/bin/bash -expected='(lambda l l)(1 2 3 4 5 6 7 8 9 10)' -actual=`target/psse 2>/dev/null <