Initial commit
This commit is contained in:
rxi
commit
a83bc9783c
|
|
@ -0,0 +1,19 @@
|
|||
Copyright (c) 2019 rxi
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy of
|
||||
this software and associated documentation files (the "Software"), to deal in
|
||||
the Software without restriction, including without limitation the rights to
|
||||
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
|
||||
of the Software, and to permit persons to whom the Software is furnished to do
|
||||
so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
# fe
|
||||
A *tiny*, embeddable language implemented in ANSI C
|
||||
|
||||
```clojure
|
||||
(= reverse (fn (lst)
|
||||
(let res nil)
|
||||
(while lst
|
||||
(= res (cons (car lst) res))
|
||||
(= lst (cdr lst))
|
||||
)
|
||||
res
|
||||
))
|
||||
|
||||
(= animals '("cat" "dog" "fox"))
|
||||
|
||||
(print (reverse animals)) ; => ("fox" "dog" "cat")
|
||||
```
|
||||
|
||||
## Overview
|
||||
* Supports numbers, symbols, strings, pairs, lambdas, macros
|
||||
* Lexically scoped variables, closures
|
||||
* Small memory usage within a fixed-sized memory region — no mallocs
|
||||
* Simple mark and sweep garbage collector
|
||||
* Easy to use C API
|
||||
* Portable ANSI C — works on 32 and 64bit
|
||||
* Concise — less than 800 sloc
|
||||
|
||||
---
|
||||
|
||||
* **[Demo Scripts](scripts)**
|
||||
* **[Language Overview](doc/lang.md)**
|
||||
* **[Implementation Overview](doc/impl.md)**
|
||||
|
||||
|
||||
## Contributing
|
||||
The library focuses on being lightweight and minimal; pull requests will
|
||||
likely not be merged. Bug reports and questions are welcome.
|
||||
|
||||
|
||||
## License
|
||||
This library is free software; you can redistribute it and/or modify it under
|
||||
the terms of the MIT license. See [LICENSE](LICENSE) for details.
|
||||
|
|
@ -0,0 +1,155 @@
|
|||
|
||||
# Implementation
|
||||
|
||||
## Overview
|
||||
The implementation aims to fulfill the following goals:
|
||||
* Small memory usage within a fixed-sized memory region — no mallocs
|
||||
* Practical for small scripts (extension scripts, config files)
|
||||
* Concise source — less than 1000 loc
|
||||
* Portable ANSI C (Windows, Linux, DOS — 32 and 64bit)
|
||||
* Simple and easy to understand source
|
||||
* Simple and easy to use C API
|
||||
|
||||
The language offers the following:
|
||||
* Numbers, symbols, strings, pairs, lambdas, macros, cfuncs, ptrs
|
||||
* Lexically scoped variables
|
||||
* Closures
|
||||
* Variadic functions
|
||||
* Mark and sweep garbage collector
|
||||
* Stack traceback on error
|
||||
|
||||
|
||||
## Memory
|
||||
The implementation uses a fixed-sized region of memory supplied by the user when
|
||||
creating the `context`. The implementation stores the `context` at the start of
|
||||
this memory region and uses the rest of the region to store `object`s.
|
||||
|
||||
|
||||
## Objects
|
||||
All data is stored in fixed-sized `object`s. Each `object` consists of a `car`
|
||||
and `cdr`. The lowest bit of an `object`'s `car` stores type information — if
|
||||
the `object` is a `PAIR` (cons cell) the lowest bit is `0`, otherwise it is `1`.
|
||||
The second-lowest bit is used by the garbage collector to mark the object and is
|
||||
always `0` outside of the `collectgarbage()` function.
|
||||
|
||||
Pairs use the `car` and `cdr` as pointers to other `object`s. As all
|
||||
`object`s are at least 4byte-aligned we can always assume the lower two
|
||||
bits on a pointer referencing an `object` are `0`.
|
||||
|
||||
Non-pair `object`s store their full type in the first byte of `car`.
|
||||
|
||||
##### String
|
||||
Strings are stored using multiple `object`s of type `STRING` linked together —
|
||||
each string `object` stores a part of the string in the bytes of `car` not used
|
||||
by the type and gc mark. The `cdr` stores the `object` with the next part of
|
||||
the string or `nil` if this was the last part of the string.
|
||||
|
||||
##### Symbol
|
||||
Symbols store a pair object in the `cdr`; the `car` of this pair contains a
|
||||
`string` object, the `cdr` part contains the globally bound value for the
|
||||
symbol. Symbols are interned.
|
||||
|
||||
##### Number
|
||||
Numbers store a `Number` in the `cdr` part of the `object`. By default
|
||||
`Number` is a `float`, but any value can be used so long as it is equal
|
||||
or smaller in size than an `object` pointer. If a different type of
|
||||
value is used, `lsp_read()` and `lsp_write()` must also be updated to
|
||||
handle the new type correctly.
|
||||
|
||||
##### Prim
|
||||
Primitives (built-ins) store an enum in the `cdr` part of the `object`.
|
||||
|
||||
##### CFunc
|
||||
CFuncs store a `CFunc` pointer in the `cdr` part of the `object`.
|
||||
|
||||
##### Ptr
|
||||
Ptrs store a `void` pointer in the `cdr` part of the `object`. The handler
|
||||
functions `gc` and `mark` are called whenever a `ptr` is collected or marked by
|
||||
the garbage collector — the set `lsp_CFunc` is passed the object itself in place
|
||||
of an arguments list.
|
||||
|
||||
|
||||
## Environments
|
||||
Environments are stored as association lists, for example: an environment with
|
||||
the symbol `x` bound to `10` and `y` bound to `20` would be
|
||||
`((x . 10) (y . 20))`. Globally bound values are stored directly in the `symbol`
|
||||
object.
|
||||
|
||||
|
||||
## Macros
|
||||
Macros work similar to functions, but receive their arguments unevaluated and
|
||||
return code which is evaluated in the scope of the caller. The first time a
|
||||
macro is called the code which called it is replaced by the generated code, such
|
||||
that the macro itself is only ran once in each place it is called. For example,
|
||||
we could define the following macro to increment a value by one:
|
||||
|
||||
```clojure
|
||||
(= incr
|
||||
(mac (sym)
|
||||
(list '= sym (list '+ sym 1))))
|
||||
```
|
||||
|
||||
And use it in the following while loop:
|
||||
|
||||
```clojure
|
||||
(= i 0)
|
||||
(while (< i 0)
|
||||
(print i)
|
||||
(incr i))
|
||||
```
|
||||
|
||||
Upon the first call to `incr`, the program code would be modified in-place,
|
||||
replacing the call to the macro with the code it generated:
|
||||
|
||||
```clojure
|
||||
(= i 0)
|
||||
(while (< i 0)
|
||||
(print i)
|
||||
(= i (+ i 1)))
|
||||
```
|
||||
|
||||
Subsequent iterations of the loop would run the new code which now exists where
|
||||
the macro call was originally.
|
||||
|
||||
|
||||
## Garbage Collection
|
||||
A simple mark-and-sweep garbage collector is used in conjunction with a
|
||||
`freelist`. When the `context` is initialized a `freelist` is created from all
|
||||
the `object`s. When an `object` is required it is popped from the `freelist`. If
|
||||
there are no more `object`s on the `freelist` the garbage collector does a full
|
||||
mark-and-sweep, pushing unreachable `object`s back to the `freelist`, thus
|
||||
garbage collection may occur whenever a new `object` is created.
|
||||
|
||||
The `context` maintains a `gcstack` — this is used to protect `object`s which
|
||||
may not be reachable from being collected. These may include, for example:
|
||||
`object`s returned after an eval, or a list which is currently being constructed
|
||||
from multiple pairs. Newly created `object`s are automatically pushed to this
|
||||
stack.
|
||||
|
||||
|
||||
## Error Handling
|
||||
If an error occurs the `lsp_error()` function is called — this function resets
|
||||
the `context` to a safe state and calls the `error` handler if one is set. The
|
||||
error handler function is passed the error message and list representing the
|
||||
call stack (*both these values are valid only for this function*). The error
|
||||
handler can be safely longjmp'd out of to recover from the error and use of the
|
||||
`context` can continue — this can be seen in the REPL. New `object`s should not
|
||||
be created from inside the error handler.
|
||||
|
||||
If no error handler is set or if the error handler returns then the error
|
||||
message and callstack are printed to `stderr` and `exit` is called with the
|
||||
value `EXIT_FAILURE`.
|
||||
|
||||
|
||||
## Known Issues
|
||||
The implementation has some known issues; these exist as a side effect of trying
|
||||
to keep the implementation terse, but should not hinder normal usage:
|
||||
|
||||
* The garbage collector recurses on the `CAR` of objects thus deeply nested
|
||||
`CAR`s may overflow the C stack — an object's `CDR` is looped on and will not
|
||||
overflow the stack
|
||||
* The storage of an object's type and GC mark assumes a little-endian system and
|
||||
will not work correctly on systems of other endianness
|
||||
* Proper tailcalls are not implemented — `while` can be used for iterating over
|
||||
lists
|
||||
* Strings are null-terminated and therefor not binary safe
|
||||
|
|
@ -0,0 +1,143 @@
|
|||
# Language
|
||||
|
||||
## Forms
|
||||
|
||||
### Special-forms
|
||||
##### (let sym val)
|
||||
Creates a new binding of `sym` to the value `val` in the current environment.
|
||||
|
||||
##### (= sym val)
|
||||
Sets the existing binding of `sym` to the value `val`; in lieu of an
|
||||
existing binding the global value is set.
|
||||
|
||||
##### (if cond then else ...)
|
||||
If `cond` is true evaluates `then`, else evaluates `else` — `else` and `then`
|
||||
statements can be chained to replicate the functionality of else-if blocks.
|
||||
|
||||
```clojure
|
||||
> (= x 2)
|
||||
nil
|
||||
> (if (is x 1) "one"
|
||||
(is x 2) "two"
|
||||
(is x 3) "three"
|
||||
"?")
|
||||
two
|
||||
```
|
||||
|
||||
##### (fn params ...)
|
||||
Creates a new function.
|
||||
|
||||
```clojure
|
||||
> (= sqr (fn (n) (* n n)))
|
||||
nil
|
||||
> (sqr 4)
|
||||
16
|
||||
```
|
||||
|
||||
##### (mac params ...)
|
||||
Creates a new *macro*.
|
||||
```clojure
|
||||
> (= incr (mac (x) (list '= x (list '+ x 1))))
|
||||
nil
|
||||
> (= n 0)
|
||||
nil
|
||||
> (incr n)
|
||||
nil
|
||||
> n
|
||||
1
|
||||
```
|
||||
|
||||
##### (while cond ...)
|
||||
If `cond` evaluates to true evaluates the rest of its arguments and keeps
|
||||
repeating until `cond` evaluates to `nil`.
|
||||
|
||||
```clojure
|
||||
> (= i 0)
|
||||
nil
|
||||
> (while (< i 3)
|
||||
(print i)
|
||||
(= i (+ i 1)))
|
||||
0
|
||||
1
|
||||
2
|
||||
nil
|
||||
```
|
||||
|
||||
##### (quote val)
|
||||
Returns `val` unevaluated.
|
||||
|
||||
```clojure
|
||||
> (quote (hello world))
|
||||
(hello world)
|
||||
```
|
||||
|
||||
##### (and ...)
|
||||
Evaluates each argument until one results in `nil` — the last argument's value
|
||||
is returned if all the arguments are true.
|
||||
|
||||
##### (or ...)
|
||||
Evaluates each argument until one results in true, in which case that arguments
|
||||
value is returned — `nil` is returned if no arguments are true.
|
||||
|
||||
##### (do ...)
|
||||
Evaluates each of its arguments and returns the value of the last one.
|
||||
|
||||
### Functions
|
||||
##### (cons car cdr)
|
||||
Creates a new pair with the given `car` and `cdr` values.
|
||||
|
||||
##### (car pair)
|
||||
Returns the `car` of the `pair` or `nil` if `pair` is `nil`.
|
||||
|
||||
##### (cdr pair)
|
||||
Returns the `cdr` of the `pair` or `nil` if `pair` is `nil`.
|
||||
|
||||
##### (setcar pair val)
|
||||
Sets the `car` of `pair` to `val`.
|
||||
|
||||
##### (setcdr pair val)
|
||||
Sets the `cdr` of `pair` to `val`.
|
||||
|
||||
##### (list ...)
|
||||
Returns all its arguments as a list.
|
||||
```clojure
|
||||
> (list 1 2 3)
|
||||
(1 2 3)
|
||||
```
|
||||
|
||||
##### (not val)
|
||||
Returns true if `val` is `nil`, else returns `nil`
|
||||
```clojure
|
||||
> (not 1)
|
||||
nil
|
||||
```
|
||||
|
||||
##### (is a b)
|
||||
Returns true if the values `a` and `b` are equal in value. Numbers and strings
|
||||
are equal if equivalent, all other values are equal only if it is the same
|
||||
underlying object.
|
||||
|
||||
##### (atom x)
|
||||
Returns true if `x` is not a pair, otherwise `nil`.
|
||||
|
||||
##### (print ...)
|
||||
Prints all it's arguments to `stdout`, each separated by a space and followed by
|
||||
a new line.
|
||||
|
||||
##### (< a b)
|
||||
Returns true if the numerical value `a` is less than `b`.
|
||||
|
||||
##### (<= a b)
|
||||
Returns true if the numerical value `a` is less than or equal to `b`.
|
||||
|
||||
##### (+ ...)
|
||||
Adds all its arguments together.
|
||||
|
||||
##### (- ...)
|
||||
Subtracts all its arguments, left-to-right.
|
||||
|
||||
##### (* ...)
|
||||
Multiplies all its arguments.
|
||||
|
||||
##### (/ ...)
|
||||
Divides all its arguments, left-to-right.
|
||||
|
|
@ -0,0 +1,884 @@
|
|||
/*
|
||||
** Copyright (c) 2019 rxi
|
||||
**
|
||||
** Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
** of this software and associated documentation files (the "Software"), to
|
||||
** deal in the Software without restriction, including without limitation the
|
||||
** rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
|
||||
** sell copies of the Software, and to permit persons to whom the Software is
|
||||
** furnished to do so, subject to the following conditions:
|
||||
**
|
||||
** The above copyright notice and this permission notice shall be included in
|
||||
** all copies or substantial portions of the Software.
|
||||
**
|
||||
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
** IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
** FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
** AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
** LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
||||
** FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
|
||||
** IN THE SOFTWARE.
|
||||
*/
|
||||
|
||||
#include <string.h>
|
||||
#include "fe.h"
|
||||
|
||||
#define unused(x) ( (void) (x) )
|
||||
#define car(x) ( (x)->car.o )
|
||||
#define cdr(x) ( (x)->cdr.o )
|
||||
#define tag(x) ( (x)->car.c )
|
||||
#define isnil(x) ( (x) == &nil )
|
||||
#define type(x) ( tag(x) & 0x1 ? tag(x) >> 2 : FE_TPAIR )
|
||||
#define settype(x,t) ( tag(x) = (t) << 2 | 1 )
|
||||
#define number(x) ( (x)->cdr.n )
|
||||
#define prim(x) ( (x)->cdr.c )
|
||||
#define cfunc(x) ( (x)->cdr.f )
|
||||
#define strbuf(x) ( &(x)->car.c + 1 )
|
||||
|
||||
#define STRBUFSIZE ( (int) sizeof(fe_Object*) - 1 )
|
||||
#define GCMARKBIT ( 0x2 )
|
||||
#define GCSTACKSIZE ( 256 )
|
||||
|
||||
|
||||
enum {
|
||||
P_LET, P_SET, P_IF, P_FN, P_MAC, P_WHILE, P_QUOTE, P_AND, P_OR, P_DO, P_CONS,
|
||||
P_CAR, P_CDR, P_SETCAR, P_SETCDR, P_LIST, P_NOT, P_IS, P_ATOM, P_PRINT, P_LT,
|
||||
P_LTE, P_ADD, P_SUB, P_MUL, P_DIV, P_MAX
|
||||
};
|
||||
|
||||
static const char *primnames[] = {
|
||||
"let", "=", "if", "fn", "mac", "while", "quote", "and", "or", "do", "cons",
|
||||
"car", "cdr", "setcar", "setcdr", "list", "not", "is", "atom", "print", "<",
|
||||
"<=", "+", "-", "*", "/"
|
||||
};
|
||||
|
||||
static const char *typenames[] = {
|
||||
"pair", "free", "nil", "number", "symbol", "string",
|
||||
"func", "macro", "prim", "cfunc", "ptr"
|
||||
};
|
||||
|
||||
typedef union { fe_Object *o; fe_CFunc f; fe_Number n; char c; } Value;
|
||||
|
||||
struct fe_Object { Value car, cdr; };
|
||||
|
||||
struct fe_Context {
|
||||
fe_Handlers handlers;
|
||||
fe_Object *gcstack[GCSTACKSIZE];
|
||||
int gcstack_idx;
|
||||
fe_Object *objects;
|
||||
int object_count;
|
||||
fe_Object *calllist;
|
||||
fe_Object *freelist;
|
||||
fe_Object *symlist;
|
||||
fe_Object *t;
|
||||
int nextchr;
|
||||
};
|
||||
|
||||
static fe_Object nil = {{ (void*) (FE_TNIL << 2 | 1) }, { NULL }};
|
||||
|
||||
|
||||
fe_Handlers* fe_handlers(fe_Context *ctx) {
|
||||
return &ctx->handlers;
|
||||
}
|
||||
|
||||
|
||||
void fe_error(fe_Context *ctx, const char *msg) {
|
||||
fe_Object *cl = ctx->calllist;
|
||||
/* reset context state */
|
||||
ctx->calllist = &nil;
|
||||
/* do error handler */
|
||||
if (ctx->handlers.error) { ctx->handlers.error(ctx, msg, cl); }
|
||||
/* error handler returned -- print error and traceback, exit */
|
||||
fprintf(stderr, "error: %s\n", msg);
|
||||
for (; !isnil(cl); cl = cdr(cl)) {
|
||||
char buf[64];
|
||||
fe_tostring(ctx, car(cl), buf, sizeof(buf));
|
||||
fprintf(stderr, "=> %s\n", buf);
|
||||
}
|
||||
exit(EXIT_FAILURE);
|
||||
}
|
||||
|
||||
|
||||
fe_Object* fe_nextarg(fe_Context *ctx, fe_Object **arg) {
|
||||
fe_Object *a = *arg;
|
||||
if (type(a) != FE_TPAIR) {
|
||||
if (isnil(a)) { fe_error(ctx, "too few arguments"); }
|
||||
fe_error(ctx, "dotted pair in argument list");
|
||||
}
|
||||
*arg = cdr(a);
|
||||
return car(a);
|
||||
}
|
||||
|
||||
|
||||
static fe_Object* checktype(fe_Context *ctx, fe_Object *obj, int type) {
|
||||
char buf[64];
|
||||
if (type(obj) != type) {
|
||||
sprintf(buf, "expected %s, got %s", typenames[type], typenames[type(obj)]);
|
||||
fe_error(ctx, buf);
|
||||
}
|
||||
return obj;
|
||||
}
|
||||
|
||||
|
||||
int fe_type(fe_Context *ctx, fe_Object *obj) {
|
||||
unused(ctx);
|
||||
return type(obj);
|
||||
}
|
||||
|
||||
|
||||
int fe_isnil(fe_Context *ctx, fe_Object *obj) {
|
||||
unused(ctx);
|
||||
return isnil(obj);
|
||||
}
|
||||
|
||||
|
||||
void fe_pushgc(fe_Context *ctx, fe_Object *obj) {
|
||||
if (ctx->gcstack_idx == GCSTACKSIZE) {
|
||||
fe_error(ctx, "gc stack overflow");
|
||||
}
|
||||
ctx->gcstack[ctx->gcstack_idx++] = obj;
|
||||
}
|
||||
|
||||
|
||||
void fe_restoregc(fe_Context *ctx, int idx) {
|
||||
ctx->gcstack_idx = idx;
|
||||
}
|
||||
|
||||
|
||||
int fe_savegc(fe_Context *ctx) {
|
||||
return ctx->gcstack_idx;
|
||||
}
|
||||
|
||||
|
||||
void fe_mark(fe_Context *ctx, fe_Object *obj) {
|
||||
fe_Object *car;
|
||||
begin:
|
||||
if (tag(obj) & GCMARKBIT) { return; }
|
||||
car = car(obj); /* store car before modifying it with GCMARKBIT */
|
||||
tag(obj) |= GCMARKBIT;
|
||||
|
||||
switch (type(obj)) {
|
||||
case FE_TPAIR:
|
||||
fe_mark(ctx, car);
|
||||
/* fall through */
|
||||
case FE_TFUNC: case FE_TMACRO: case FE_TSYMBOL: case FE_TSTRING:
|
||||
obj = cdr(obj);
|
||||
goto begin;
|
||||
|
||||
case FE_TPTR:
|
||||
if (ctx->handlers.mark) { ctx->handlers.mark(ctx, obj); }
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
static void collectgarbage(fe_Context *ctx) {
|
||||
int i;
|
||||
/* mark */
|
||||
for (i = 0; i < ctx->gcstack_idx; i++) {
|
||||
fe_mark(ctx, ctx->gcstack[i]);
|
||||
}
|
||||
fe_mark(ctx, ctx->symlist);
|
||||
/* sweep and unmark */
|
||||
for (i = 0; i < ctx->object_count; i++) {
|
||||
fe_Object *obj = &ctx->objects[i];
|
||||
if (type(obj) == FE_TFREE) { continue; }
|
||||
if (~tag(obj) & GCMARKBIT) {
|
||||
if (type(obj) == FE_TPTR && ctx->handlers.gc) {
|
||||
ctx->handlers.gc(ctx, obj);
|
||||
}
|
||||
settype(obj, FE_TFREE);
|
||||
cdr(obj) = ctx->freelist;
|
||||
ctx->freelist = obj;
|
||||
} else {
|
||||
tag(obj) &= ~GCMARKBIT;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
static int equal(fe_Object *a, fe_Object *b) {
|
||||
if (a == b) { return 1; }
|
||||
if (type(a) != type(b)) { return 0; }
|
||||
if (type(a) == FE_TNUMBER) { return number(a) == number(b); }
|
||||
if (type(a) == FE_TSTRING) {
|
||||
for (; !isnil(a) && !isnil(b); a = cdr(a), b = cdr(b)) {
|
||||
if (car(a) != car(b)) { return 0; }
|
||||
}
|
||||
return isnil(a) && isnil(b);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
static int streq(fe_Object *obj, const char *str) {
|
||||
while (!isnil(obj)) {
|
||||
int i;
|
||||
for (i = 0; i < STRBUFSIZE; i++) {
|
||||
if (strbuf(obj)[i] != *str) { return 0; }
|
||||
if (*str) { str++; }
|
||||
}
|
||||
obj = cdr(obj);
|
||||
}
|
||||
return *str == '\0';
|
||||
}
|
||||
|
||||
|
||||
static fe_Object* object(fe_Context *ctx) {
|
||||
fe_Object *obj;
|
||||
/* do gc if freelist has no more objects */
|
||||
if (isnil(ctx->freelist)) {
|
||||
collectgarbage(ctx);
|
||||
if (isnil(ctx->freelist)) { fe_error(ctx, "out of memory"); }
|
||||
}
|
||||
/* get object from freelist and push to the gcstack */
|
||||
obj = ctx->freelist;
|
||||
ctx->freelist = cdr(obj);
|
||||
fe_pushgc(ctx, obj);
|
||||
return obj;
|
||||
}
|
||||
|
||||
|
||||
fe_Object* fe_cons(fe_Context *ctx, fe_Object *car, fe_Object *cdr) {
|
||||
fe_Object *obj = object(ctx);
|
||||
car(obj) = car;
|
||||
cdr(obj) = cdr;
|
||||
return obj;
|
||||
}
|
||||
|
||||
|
||||
fe_Object* fe_bool(fe_Context *ctx, int b) {
|
||||
return b ? ctx->t : &nil;
|
||||
}
|
||||
|
||||
|
||||
fe_Object* fe_number(fe_Context *ctx, fe_Number n) {
|
||||
fe_Object *obj = object(ctx);
|
||||
settype(obj, FE_TNUMBER);
|
||||
number(obj) = n;
|
||||
return obj;
|
||||
}
|
||||
|
||||
|
||||
static fe_Object* buildstring(fe_Context *ctx, fe_Object *tail, int chr) {
|
||||
if (!tail || strbuf(tail)[STRBUFSIZE - 1] != '\0') {
|
||||
fe_Object *obj = fe_cons(ctx, NULL, &nil);
|
||||
settype(obj, FE_TSTRING);
|
||||
if (tail) {
|
||||
cdr(tail) = obj;
|
||||
ctx->gcstack_idx--;
|
||||
}
|
||||
tail = obj;
|
||||
}
|
||||
strbuf(tail)[strlen(strbuf(tail))] = chr;
|
||||
return tail;
|
||||
}
|
||||
|
||||
|
||||
fe_Object* fe_string(fe_Context *ctx, const char *str) {
|
||||
fe_Object *obj = buildstring(ctx, NULL, '\0');
|
||||
fe_Object *tail = obj;
|
||||
while (*str) {
|
||||
tail = buildstring(ctx, tail, *str++);
|
||||
}
|
||||
return obj;
|
||||
}
|
||||
|
||||
|
||||
fe_Object* fe_symbol(fe_Context *ctx, const char *name) {
|
||||
fe_Object *obj;
|
||||
/* try to find in symlist */
|
||||
for (obj = ctx->symlist; !isnil(obj); obj = cdr(obj)) {
|
||||
if (streq(car(cdr(car(obj))), name)) {
|
||||
return car(obj);
|
||||
}
|
||||
}
|
||||
/* create new object, push to symlist and return */
|
||||
obj = object(ctx);
|
||||
settype(obj, FE_TSYMBOL);
|
||||
cdr(obj) = fe_cons(ctx, fe_string(ctx, name), &nil);
|
||||
ctx->symlist = fe_cons(ctx, obj, ctx->symlist);
|
||||
return obj;
|
||||
}
|
||||
|
||||
|
||||
fe_Object* fe_cfunc(fe_Context *ctx, fe_CFunc fn) {
|
||||
fe_Object *obj = object(ctx);
|
||||
settype(obj, FE_TCFUNC);
|
||||
cfunc(obj) = fn;
|
||||
return obj;
|
||||
}
|
||||
|
||||
|
||||
fe_Object* fe_ptr(fe_Context *ctx, void *ptr) {
|
||||
fe_Object *obj = object(ctx);
|
||||
settype(obj, FE_TPTR);
|
||||
cdr(obj) = ptr;
|
||||
return obj;
|
||||
}
|
||||
|
||||
|
||||
fe_Object* fe_list(fe_Context *ctx, fe_Object **objs, int n) {
|
||||
fe_Object *res = &nil;
|
||||
while (n--) {
|
||||
res = fe_cons(ctx, objs[n], res);
|
||||
}
|
||||
return res;
|
||||
}
|
||||
|
||||
|
||||
fe_Object* fe_car(fe_Context *ctx, fe_Object *obj) {
|
||||
if (isnil(obj)) { return obj; }
|
||||
return car(checktype(ctx, obj, FE_TPAIR));
|
||||
}
|
||||
|
||||
|
||||
fe_Object* fe_cdr(fe_Context *ctx, fe_Object *obj) {
|
||||
if (isnil(obj)) { return obj; }
|
||||
return cdr(checktype(ctx, obj, FE_TPAIR));
|
||||
}
|
||||
|
||||
|
||||
static void writestr(fe_Context *ctx, fe_WriteFn fn, void *udata, const char *s) {
|
||||
while (*s) { fn(ctx, udata, *s++); }
|
||||
}
|
||||
|
||||
void fe_write(fe_Context *ctx, fe_Object *obj, fe_WriteFn fn, void *udata, int qt) {
|
||||
char buf[32];
|
||||
|
||||
switch (type(obj)) {
|
||||
case FE_TNIL:
|
||||
writestr(ctx, fn, udata, "nil");
|
||||
break;
|
||||
|
||||
case FE_TNUMBER:
|
||||
sprintf(buf, "%.7g", number(obj));
|
||||
writestr(ctx, fn, udata, buf);
|
||||
break;
|
||||
|
||||
case FE_TPAIR:
|
||||
fn(ctx, udata, '(');
|
||||
for (;;) {
|
||||
fe_write(ctx, car(obj), fn, udata, 1);
|
||||
obj = cdr(obj);
|
||||
if (type(obj) != FE_TPAIR) { break; }
|
||||
fn(ctx, udata, ' ');
|
||||
}
|
||||
if (!isnil(obj)) {
|
||||
writestr(ctx, fn, udata, " . ");
|
||||
fe_write(ctx, obj, fn, udata, 1);
|
||||
}
|
||||
fn(ctx, udata, ')');
|
||||
break;
|
||||
|
||||
case FE_TSYMBOL:
|
||||
fe_write(ctx, car(cdr(obj)), fn, udata, 0);
|
||||
break;
|
||||
|
||||
case FE_TSTRING:
|
||||
if (qt) { fn(ctx, udata, '"'); }
|
||||
while (!isnil(obj)) {
|
||||
int i;
|
||||
for (i = 0; i < STRBUFSIZE && strbuf(obj)[i]; i++) {
|
||||
if (qt && strbuf(obj)[i] == '"') { fn(ctx, udata, '\\'); }
|
||||
fn(ctx, udata, strbuf(obj)[i]);
|
||||
}
|
||||
obj = cdr(obj);
|
||||
}
|
||||
if (qt) { fn(ctx, udata, '"'); }
|
||||
break;
|
||||
|
||||
default:
|
||||
sprintf(buf, "[%s %p]", typenames[type(obj)], (void*) obj);
|
||||
writestr(ctx, fn, udata, buf);
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
static void writefp(fe_Context *ctx, void *udata, char chr) {
|
||||
unused(ctx);
|
||||
fputc(chr, udata);
|
||||
}
|
||||
|
||||
void fe_writefp(fe_Context *ctx, fe_Object *obj, FILE *fp) {
|
||||
fe_write(ctx, obj, writefp, fp, 0);
|
||||
}
|
||||
|
||||
|
||||
typedef struct { char *p; int n; } CharPtrInt;
|
||||
|
||||
static void writebuf(fe_Context *ctx, void *udata, char chr) {
|
||||
CharPtrInt *x = udata;
|
||||
unused(ctx);
|
||||
if (x->n) { *x->p++ = chr; x->n--; }
|
||||
}
|
||||
|
||||
int fe_tostring(fe_Context *ctx, fe_Object *obj, char *dst, int size) {
|
||||
CharPtrInt x;
|
||||
x.p = dst;
|
||||
x.n = size - 1;
|
||||
fe_write(ctx, obj, writebuf, &x, 0);
|
||||
*x.p = '\0';
|
||||
return size - x.n - 1;
|
||||
}
|
||||
|
||||
|
||||
fe_Number fe_tonumber(fe_Context *ctx, fe_Object *obj) {
|
||||
return number(checktype(ctx, obj, FE_TNUMBER));
|
||||
}
|
||||
|
||||
|
||||
void* fe_toptr(fe_Context *ctx, fe_Object *obj) {
|
||||
return cdr(checktype(ctx, obj, FE_TPTR));
|
||||
}
|
||||
|
||||
|
||||
static fe_Object* getbound(fe_Object *sym, fe_Object *env) {
|
||||
/* try to find in environment */
|
||||
for (; !isnil(env); env = cdr(env)) {
|
||||
fe_Object *x = car(env);
|
||||
if (car(x) == sym) { return x; }
|
||||
}
|
||||
/* return global */
|
||||
return cdr(sym);
|
||||
}
|
||||
|
||||
|
||||
void fe_set(fe_Context *ctx, fe_Object *sym, fe_Object *v) {
|
||||
unused(ctx);
|
||||
cdr(getbound(sym, &nil)) = v;
|
||||
}
|
||||
|
||||
|
||||
static fe_Object rparen;
|
||||
|
||||
static fe_Object* read_(fe_Context *ctx, fe_ReadFn fn, void *udata) {
|
||||
const char *delimiter = " \n\t\r();";
|
||||
fe_Object *v, *res, **tail;
|
||||
fe_Number n;
|
||||
int chr, gc;
|
||||
char buf[64], *p;
|
||||
|
||||
/* get next character */
|
||||
chr = ctx->nextchr ? ctx->nextchr : fn(ctx, udata);
|
||||
ctx->nextchr = '\0';
|
||||
|
||||
/* skip whitespace */
|
||||
while (chr && strchr(" \n\t\r", chr)) {
|
||||
chr = fn(ctx, udata);
|
||||
}
|
||||
|
||||
switch (chr) {
|
||||
case '\0':
|
||||
return NULL;
|
||||
|
||||
case ';':
|
||||
while (chr && chr != '\n') { chr = fn(ctx, udata); }
|
||||
return read_(ctx, fn, udata);
|
||||
|
||||
case ')':
|
||||
return &rparen;
|
||||
|
||||
case '(':
|
||||
res = &nil;
|
||||
tail = &res;
|
||||
gc = fe_savegc(ctx);
|
||||
fe_pushgc(ctx, res); /* to cause error on too-deep nesting */
|
||||
while ( (v = read_(ctx, fn, udata)) != &rparen ) {
|
||||
if (v == NULL) { fe_error(ctx, "unclosed list"); }
|
||||
if (type(v) == FE_TSYMBOL && streq(car(cdr(v)), ".")) {
|
||||
/* dotted pair */
|
||||
*tail = fe_read(ctx, fn, udata);
|
||||
} else {
|
||||
/* proper pair */
|
||||
*tail = fe_cons(ctx, v, &nil);
|
||||
tail = &cdr(*tail);
|
||||
}
|
||||
fe_restoregc(ctx, gc);
|
||||
fe_pushgc(ctx, res);
|
||||
}
|
||||
return res;
|
||||
|
||||
case '\'':
|
||||
v = fe_read(ctx, fn, udata);
|
||||
if (!v) { fe_error(ctx, "stray '''"); }
|
||||
return fe_cons(ctx, fe_symbol(ctx, "quote"), fe_cons(ctx, v, &nil));
|
||||
|
||||
case '"':
|
||||
res = buildstring(ctx, NULL, '\0');
|
||||
v = res;
|
||||
chr = fn(ctx, udata);
|
||||
while (chr != '"') {
|
||||
if (chr == '\0') { fe_error(ctx, "unclosed string"); }
|
||||
if (chr == '\\') {
|
||||
chr = fn(ctx, udata);
|
||||
if (strchr("nrt", chr)) { chr = strchr("n\nr\rt\t", chr)[1]; }
|
||||
}
|
||||
v = buildstring(ctx, v, chr);
|
||||
chr = fn(ctx, udata);
|
||||
}
|
||||
return res;
|
||||
|
||||
default:
|
||||
p = buf;
|
||||
do {
|
||||
if (p == buf + sizeof(buf) - 1) { fe_error(ctx, "symbol too long"); }
|
||||
*p++ = chr;
|
||||
chr = fn(ctx, udata);
|
||||
} while (chr && !strchr(delimiter, chr));
|
||||
*p = '\0';
|
||||
ctx->nextchr = chr;
|
||||
n = strtod(buf, &p); /* try to read as number */
|
||||
if (p != buf && strchr(delimiter, *p)) { return fe_number(ctx, n); }
|
||||
if (!strcmp(buf, "nil")) { return &nil; }
|
||||
return fe_symbol(ctx, buf);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
fe_Object* fe_read(fe_Context *ctx, fe_ReadFn fn, void *udata) {
|
||||
fe_Object* obj = read_(ctx, fn, udata);
|
||||
if (obj == &rparen) { fe_error(ctx, "stray ')'"); }
|
||||
return obj;
|
||||
}
|
||||
|
||||
|
||||
static char readfp(fe_Context *ctx, void *udata) {
|
||||
int chr;
|
||||
unused(ctx);
|
||||
return (chr = fgetc(udata)) == EOF ? '\0' : chr;
|
||||
}
|
||||
|
||||
fe_Object* fe_readfp(fe_Context *ctx, FILE *fp) {
|
||||
return fe_read(ctx, readfp, fp);
|
||||
}
|
||||
|
||||
|
||||
static fe_Object* eval(fe_Context *ctx, fe_Object *obj, fe_Object *env, fe_Object **bind);
|
||||
|
||||
static fe_Object* evallist(fe_Context *ctx, fe_Object *lst, fe_Object *env) {
|
||||
fe_Object *res = &nil;
|
||||
fe_Object **tail = &res;
|
||||
while (!isnil(lst)) {
|
||||
*tail = fe_cons(ctx, eval(ctx, fe_nextarg(ctx, &lst), env, NULL), &nil);
|
||||
tail = &cdr(*tail);
|
||||
}
|
||||
return res;
|
||||
}
|
||||
|
||||
|
||||
static fe_Object* dolist(fe_Context *ctx, fe_Object *lst, fe_Object *env) {
|
||||
fe_Object *res = &nil;
|
||||
int save = fe_savegc(ctx);
|
||||
while (!isnil(lst)) {
|
||||
fe_restoregc(ctx, save);
|
||||
fe_pushgc(ctx, env);
|
||||
res = eval(ctx, fe_nextarg(ctx, &lst), env, &env);
|
||||
}
|
||||
return res;
|
||||
}
|
||||
|
||||
|
||||
static fe_Object* argstoenv(fe_Context *ctx, fe_Object *prm, fe_Object *arg, fe_Object *env) {
|
||||
while (!isnil(prm)) {
|
||||
if (type(prm) != FE_TPAIR) {
|
||||
env = fe_cons(ctx, fe_cons(ctx, prm, arg), env);
|
||||
break;
|
||||
}
|
||||
env = fe_cons(ctx, fe_cons(ctx, car(prm), fe_car(ctx, arg)), env);
|
||||
prm = cdr(prm);
|
||||
arg = fe_cdr(ctx, arg);
|
||||
}
|
||||
return env;
|
||||
}
|
||||
|
||||
|
||||
#define evalarg() eval(ctx, fe_nextarg(ctx, &arg), env, NULL)
|
||||
|
||||
#define arithop(op) { \
|
||||
fe_Number x = fe_tonumber(ctx, evalarg()); \
|
||||
while (!isnil(arg)) { \
|
||||
x = x op fe_tonumber(ctx, evalarg()); \
|
||||
} \
|
||||
res = fe_number(ctx, x); \
|
||||
}
|
||||
|
||||
#define numcmpop(op) { \
|
||||
va = checktype(ctx, evalarg(), FE_TNUMBER); \
|
||||
vb = checktype(ctx, evalarg(), FE_TNUMBER); \
|
||||
res = fe_bool(ctx, number(va) op number(vb)); \
|
||||
}
|
||||
|
||||
|
||||
static fe_Object* eval(fe_Context *ctx, fe_Object *obj, fe_Object *env, fe_Object **newenv) {
|
||||
fe_Object *fn, *arg, *res;
|
||||
fe_Object cl, *va, *vb;
|
||||
int n, gc;
|
||||
|
||||
switch (type(obj)) {
|
||||
case FE_TSYMBOL: return cdr(getbound(obj, env));
|
||||
case FE_TPAIR: break;
|
||||
default: return obj;
|
||||
}
|
||||
|
||||
car(&cl) = obj, cdr(&cl) = ctx->calllist;
|
||||
ctx->calllist = &cl;
|
||||
|
||||
gc = fe_savegc(ctx);
|
||||
fn = eval(ctx, car(obj), env, NULL);
|
||||
arg = cdr(obj);
|
||||
res = &nil;
|
||||
|
||||
switch (type(fn)) {
|
||||
case FE_TPRIM:
|
||||
switch (prim(fn)) {
|
||||
case P_LET:
|
||||
va = checktype(ctx, fe_nextarg(ctx, &arg), FE_TSYMBOL);
|
||||
if (newenv) {
|
||||
*newenv = fe_cons(ctx, fe_cons(ctx, va, evalarg()), env);
|
||||
}
|
||||
break;
|
||||
|
||||
case P_SET:
|
||||
va = checktype(ctx, fe_nextarg(ctx, &arg), FE_TSYMBOL);
|
||||
cdr(getbound(va, env)) = evalarg();
|
||||
break;
|
||||
|
||||
case P_IF:
|
||||
while (!isnil(arg)) {
|
||||
va = evalarg();
|
||||
if (!isnil(va)) {
|
||||
res = isnil(arg) ? va : evalarg();
|
||||
break;
|
||||
}
|
||||
if (isnil(arg)) { break; }
|
||||
arg = cdr(arg);
|
||||
}
|
||||
break;
|
||||
|
||||
case P_FN: case P_MAC:
|
||||
va = fe_cons(ctx, env, arg);
|
||||
fe_nextarg(ctx, &arg);
|
||||
res = object(ctx);
|
||||
settype(res, prim(fn) == P_FN ? FE_TFUNC : FE_TMACRO);
|
||||
cdr(res) = va;
|
||||
break;
|
||||
|
||||
case P_WHILE:
|
||||
va = fe_nextarg(ctx, &arg);
|
||||
n = fe_savegc(ctx);
|
||||
while (!isnil(eval(ctx, va, env, NULL))) {
|
||||
dolist(ctx, arg, env);
|
||||
fe_restoregc(ctx, n);
|
||||
}
|
||||
break;
|
||||
|
||||
case P_QUOTE:
|
||||
res = fe_nextarg(ctx, &arg);
|
||||
break;
|
||||
|
||||
case P_AND:
|
||||
while (!isnil(arg) && !isnil(res = evalarg()));
|
||||
break;
|
||||
|
||||
case P_OR:
|
||||
while (!isnil(arg) && isnil(res = evalarg()));
|
||||
break;
|
||||
|
||||
case P_DO:
|
||||
res = dolist(ctx, arg, env);
|
||||
break;
|
||||
|
||||
case P_CONS:
|
||||
va = evalarg();
|
||||
res = fe_cons(ctx, va, evalarg());
|
||||
break;
|
||||
|
||||
case P_CAR:
|
||||
res = fe_car(ctx, evalarg());
|
||||
break;
|
||||
|
||||
case P_CDR:
|
||||
res = fe_cdr(ctx, evalarg());
|
||||
break;
|
||||
|
||||
case P_SETCAR:
|
||||
va = checktype(ctx, evalarg(), FE_TPAIR);
|
||||
car(va) = evalarg();
|
||||
break;
|
||||
|
||||
case P_SETCDR:
|
||||
va = checktype(ctx, evalarg(), FE_TPAIR);
|
||||
cdr(va) = evalarg();
|
||||
break;
|
||||
|
||||
case P_LIST:
|
||||
res = evallist(ctx, arg, env);
|
||||
break;
|
||||
|
||||
case P_NOT:
|
||||
res = fe_bool(ctx, isnil(evalarg()));
|
||||
break;
|
||||
|
||||
case P_IS:
|
||||
va = evalarg();
|
||||
res = fe_bool(ctx, equal(va, evalarg()));
|
||||
break;
|
||||
|
||||
case P_ATOM:
|
||||
res = fe_bool(ctx, fe_type(ctx, evalarg()) != FE_TPAIR);
|
||||
break;
|
||||
|
||||
case P_PRINT:
|
||||
while (!isnil(arg)) {
|
||||
fe_writefp(ctx, evalarg(), stdout);
|
||||
if (!isnil(arg)) { printf(" "); }
|
||||
}
|
||||
printf("\n");
|
||||
break;
|
||||
|
||||
case P_LT: numcmpop(<); break;
|
||||
case P_LTE: numcmpop(<=); break;
|
||||
case P_ADD: arithop(+); break;
|
||||
case P_SUB: arithop(-); break;
|
||||
case P_MUL: arithop(*); break;
|
||||
case P_DIV: arithop(/); break;
|
||||
}
|
||||
break;
|
||||
|
||||
case FE_TCFUNC:
|
||||
res = cfunc(fn)(ctx, evallist(ctx, arg, env));
|
||||
break;
|
||||
|
||||
case FE_TFUNC:
|
||||
arg = evallist(ctx, arg, env);
|
||||
va = cdr(fn); /* (env params ...) */
|
||||
vb = cdr(va); /* (params ...) */
|
||||
res = dolist(ctx, cdr(vb), argstoenv(ctx, car(vb), arg, car(va)));
|
||||
break;
|
||||
|
||||
case FE_TMACRO:
|
||||
va = cdr(fn); /* (env params ...) */
|
||||
vb = cdr(va); /* (params ...) */
|
||||
/* replace caller object with code generated by macro and re-eval */
|
||||
*obj = *dolist(ctx, cdr(vb), argstoenv(ctx, car(vb), arg, car(va)));
|
||||
fe_restoregc(ctx, gc);
|
||||
ctx->calllist = cdr(&cl);
|
||||
return eval(ctx, obj, env, NULL);
|
||||
|
||||
default:
|
||||
fe_error(ctx, "tried to call non-callable value");
|
||||
}
|
||||
|
||||
fe_restoregc(ctx, gc);
|
||||
fe_pushgc(ctx, res);
|
||||
ctx->calllist = cdr(&cl);
|
||||
return res;
|
||||
}
|
||||
|
||||
|
||||
fe_Object* fe_eval(fe_Context *ctx, fe_Object *obj) {
|
||||
return eval(ctx, obj, &nil, NULL);
|
||||
}
|
||||
|
||||
|
||||
fe_Context* fe_open(void *ptr, int size) {
|
||||
int i, save;
|
||||
fe_Context *ctx;
|
||||
|
||||
/* init context struct */
|
||||
ctx = ptr;
|
||||
memset(ctx, 0, sizeof(fe_Context));
|
||||
ptr = (char*) ptr + sizeof(fe_Context);
|
||||
size -= sizeof(fe_Context);
|
||||
|
||||
/* make sure object memory region is 32bit aligned */
|
||||
while ((size_t) ptr & 0x3) { ptr = (char*) ptr + 1; size--; }
|
||||
|
||||
/* init objects memory region */
|
||||
ctx->objects = (fe_Object*) ptr;
|
||||
ctx->object_count = size / sizeof(fe_Object);
|
||||
|
||||
/* init lists */
|
||||
ctx->calllist = &nil;
|
||||
ctx->freelist = &nil;
|
||||
ctx->symlist = &nil;
|
||||
|
||||
/* populate freelist */
|
||||
for (i = 0; i < ctx->object_count; i++) {
|
||||
fe_Object *obj = &ctx->objects[i];
|
||||
settype(obj, FE_TFREE);
|
||||
cdr(obj) = ctx->freelist;
|
||||
ctx->freelist = obj;
|
||||
}
|
||||
|
||||
/* init objects */
|
||||
ctx->t = fe_symbol(ctx, "t");
|
||||
fe_set(ctx, ctx->t, ctx->t);
|
||||
|
||||
/* register built in primitives */
|
||||
save = fe_savegc(ctx);
|
||||
for (i = 0; i < P_MAX; i++) {
|
||||
fe_Object *v = object(ctx);
|
||||
settype(v, FE_TPRIM);
|
||||
prim(v) = i;
|
||||
fe_set(ctx, fe_symbol(ctx, primnames[i]), v);
|
||||
fe_restoregc(ctx, save);
|
||||
}
|
||||
|
||||
return ctx;
|
||||
}
|
||||
|
||||
|
||||
void fe_close(fe_Context *ctx) {
|
||||
/* clear gcstack and symlist; makes all objects unreachable */
|
||||
ctx->gcstack_idx = 0;
|
||||
ctx->symlist = &nil;
|
||||
collectgarbage(ctx);
|
||||
}
|
||||
|
||||
|
||||
#ifdef FE_STANDALONE
|
||||
|
||||
#include <setjmp.h>
|
||||
|
||||
static jmp_buf toplevel;
|
||||
static char buf[64000];
|
||||
|
||||
static void onerror(fe_Context *ctx, const char *msg, fe_Object *cl) {
|
||||
unused(ctx), unused(cl);
|
||||
fprintf(stderr, "error: %s\n", msg);
|
||||
longjmp(toplevel, -1);
|
||||
}
|
||||
|
||||
|
||||
int main(int argc, char **argv) {
|
||||
int gc;
|
||||
fe_Object *obj;
|
||||
FILE *volatile fp = stdin;
|
||||
fe_Context *ctx = fe_open(buf, sizeof(buf));
|
||||
|
||||
/* init input file */
|
||||
if (argc > 1) {
|
||||
fp = fopen(argv[1], "rb");
|
||||
if (!fp) { fe_error(ctx, "could not open input file"); }
|
||||
}
|
||||
|
||||
if (fp == stdin) { fe_handlers(ctx)->error = onerror; }
|
||||
gc = fe_savegc(ctx);
|
||||
setjmp(toplevel);
|
||||
|
||||
/* re(p)l */
|
||||
for (;;) {
|
||||
fe_restoregc(ctx, gc);
|
||||
if (fp == stdin) { printf("> "); }
|
||||
if (!(obj = fe_readfp(ctx, fp))) { break; }
|
||||
obj = fe_eval(ctx, obj);
|
||||
if (fp == stdin) { fe_writefp(ctx, obj, stdout); printf("\n"); }
|
||||
}
|
||||
|
||||
return EXIT_SUCCESS;
|
||||
}
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
/*
|
||||
** Copyright (c) 2019 rxi
|
||||
**
|
||||
** This library is free software; you can redistribute it and/or modify it
|
||||
** under the terms of the MIT license. See `fe.c` for details.
|
||||
*/
|
||||
|
||||
#ifndef FE_H
|
||||
#define FE_H
|
||||
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
|
||||
#define FE_VERSION "1.0"
|
||||
|
||||
typedef float fe_Number;
|
||||
typedef struct fe_Object fe_Object;
|
||||
typedef struct fe_Context fe_Context;
|
||||
typedef fe_Object* (*fe_CFunc)(fe_Context *ctx, fe_Object *args);
|
||||
typedef void (*fe_ErrorFn)(fe_Context *ctx, const char *err, fe_Object *cl);
|
||||
typedef void (*fe_WriteFn)(fe_Context *ctx, void *udata, char chr);
|
||||
typedef char (*fe_ReadFn)(fe_Context *ctx, void *udata);
|
||||
typedef struct { fe_ErrorFn error; fe_CFunc mark, gc; } fe_Handlers;
|
||||
|
||||
enum {
|
||||
FE_TPAIR, FE_TFREE, FE_TNIL, FE_TNUMBER, FE_TSYMBOL, FE_TSTRING,
|
||||
FE_TFUNC, FE_TMACRO, FE_TPRIM, FE_TCFUNC, FE_TPTR
|
||||
};
|
||||
|
||||
fe_Context* fe_open(void *ptr, int size);
|
||||
void fe_close(fe_Context *ctx);
|
||||
fe_Handlers* fe_handlers(fe_Context *ctx);
|
||||
void fe_error(fe_Context *ctx, const char *msg);
|
||||
fe_Object* fe_nextarg(fe_Context *ctx, fe_Object **arg);
|
||||
int fe_type(fe_Context *ctx, fe_Object *obj);
|
||||
int fe_isnil(fe_Context *ctx, fe_Object *obj);
|
||||
void fe_pushgc(fe_Context *ctx, fe_Object *obj);
|
||||
void fe_restoregc(fe_Context *ctx, int idx);
|
||||
int fe_savegc(fe_Context *ctx);
|
||||
void fe_mark(fe_Context *ctx, fe_Object *obj);
|
||||
fe_Object* fe_cons(fe_Context *ctx, fe_Object *car, fe_Object *cdr);
|
||||
fe_Object* fe_bool(fe_Context *ctx, int b);
|
||||
fe_Object* fe_number(fe_Context *ctx, fe_Number n);
|
||||
fe_Object* fe_string(fe_Context *ctx, const char *str);
|
||||
fe_Object* fe_symbol(fe_Context *ctx, const char *name);
|
||||
fe_Object* fe_cfunc(fe_Context *ctx, fe_CFunc fn);
|
||||
fe_Object* fe_ptr(fe_Context *ctx, void *ptr);
|
||||
fe_Object* fe_list(fe_Context *ctx, fe_Object **objs, int n);
|
||||
fe_Object* fe_car(fe_Context *ctx, fe_Object *obj);
|
||||
fe_Object* fe_cdr(fe_Context *ctx, fe_Object *obj);
|
||||
void fe_write(fe_Context *ctx, fe_Object *obj, fe_WriteFn fn, void *udata, int qt);
|
||||
void fe_writefp(fe_Context *ctx, fe_Object *obj, FILE *fp);
|
||||
int fe_tostring(fe_Context *ctx, fe_Object *obj, char *dst, int size);
|
||||
fe_Number fe_tonumber(fe_Context *ctx, fe_Object *obj);
|
||||
void* fe_toptr(fe_Context *ctx, fe_Object *obj);
|
||||
void fe_set(fe_Context *ctx, fe_Object *sym, fe_Object *v);
|
||||
fe_Object* fe_read(fe_Context *ctx, fe_ReadFn fn, void *udata);
|
||||
fe_Object* fe_readfp(fe_Context *ctx, FILE *fp);
|
||||
fe_Object* fe_eval(fe_Context *ctx, fe_Object *obj);
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
|
||||
(= fib (fn (n)
|
||||
(if (<= 2 n)
|
||||
(+ (fib (- n 1)) (fib (- n 2)))
|
||||
n
|
||||
)
|
||||
))
|
||||
|
||||
(print (fib 28))
|
||||
|
||||
|
|
@ -0,0 +1,112 @@
|
|||
(= nth (fn (n lst)
|
||||
(while (< 0 n)
|
||||
(= n (- n 1))
|
||||
(= lst (cdr lst)))
|
||||
(if (is n 0) (car lst))
|
||||
))
|
||||
|
||||
|
||||
(= rev (fn (lst)
|
||||
(let res nil)
|
||||
(while lst
|
||||
(= res (cons (car lst) res))
|
||||
(= lst (cdr lst))
|
||||
)
|
||||
res
|
||||
))
|
||||
|
||||
|
||||
(= map (fn (f lst)
|
||||
(let res nil)
|
||||
(while lst
|
||||
(= res (cons (f (car lst)) res))
|
||||
(= lst (cdr lst))
|
||||
)
|
||||
(rev res)
|
||||
))
|
||||
|
||||
|
||||
(= print-grid (fn (grid)
|
||||
(map
|
||||
(fn (row)
|
||||
(print (map (fn (x) (if (is x 0) '- '#)) row))
|
||||
)
|
||||
grid
|
||||
)
|
||||
))
|
||||
|
||||
|
||||
(= get-cell (fn (grid x y)
|
||||
(or (nth x (nth y grid)) 0)
|
||||
))
|
||||
|
||||
|
||||
(= next-cell (fn (grid cell x y)
|
||||
(let n (+
|
||||
(get-cell grid (- x 1) (- y 1))
|
||||
(get-cell grid (- x 1) y )
|
||||
(get-cell grid (- x 1) (+ y 1))
|
||||
(get-cell grid x (- y 1))
|
||||
(get-cell grid x (+ y 1))
|
||||
(get-cell grid (+ x 1) (- y 1))
|
||||
(get-cell grid (+ x 1) y )
|
||||
(get-cell grid (+ x 1) (+ y 1))
|
||||
))
|
||||
(if
|
||||
(and (is cell 1) (or (is n 2) (is n 3))) 1
|
||||
(and (is cell 0) (is n 3)) 1
|
||||
0
|
||||
)
|
||||
))
|
||||
|
||||
|
||||
(= next-grid (fn (grid)
|
||||
(let y -1)
|
||||
(map
|
||||
(fn (row)
|
||||
(= y (+ y 1))
|
||||
(let x -1)
|
||||
(map
|
||||
(fn (cell)
|
||||
(= x (+ x 1))
|
||||
(next-cell grid cell x y)
|
||||
)
|
||||
row
|
||||
)
|
||||
)
|
||||
grid
|
||||
)
|
||||
))
|
||||
|
||||
|
||||
(= life (fn (n grid)
|
||||
(let i 1)
|
||||
(while (<= i n)
|
||||
(print ">> iteration" i)
|
||||
(print-grid grid)
|
||||
(print)
|
||||
(= grid (next-grid grid))
|
||||
(= i (+ i 1))
|
||||
)
|
||||
))
|
||||
|
||||
|
||||
; blinker in a 3x3 universe
|
||||
(life 5 '(
|
||||
(0 1 0)
|
||||
(0 1 0)
|
||||
(0 1 0)
|
||||
))
|
||||
|
||||
|
||||
; glider in an 8x8 universe
|
||||
(life 22 '(
|
||||
(0 0 1 0 0 0 0 0)
|
||||
(0 0 0 1 0 0 0 0)
|
||||
(0 1 1 1 0 0 0 0)
|
||||
(0 0 0 0 0 0 0 0)
|
||||
(0 0 0 0 0 0 0 0)
|
||||
(0 0 0 0 0 0 0 0)
|
||||
(0 0 0 0 0 0 0 0)
|
||||
(0 0 0 0 0 0 0 0)
|
||||
))
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
; printed output should be written to a .pgm file
|
||||
|
||||
(do
|
||||
(let width 500)
|
||||
(let height 300)
|
||||
(let maxiter 16)
|
||||
|
||||
; write header
|
||||
(print "P2")
|
||||
(print width height)
|
||||
(print maxiter)
|
||||
|
||||
; write pixels
|
||||
(let ypixel 0)
|
||||
(while (< ypixel height)
|
||||
(let y (- (/ ypixel (/ height 2)) 1))
|
||||
(let xpixel 0)
|
||||
(while (< xpixel width)
|
||||
(let x (- (/ xpixel (/ width 3)) 2))
|
||||
(let x0 x)
|
||||
(let y0 y)
|
||||
(let iter 0)
|
||||
(while (and (< iter maxiter) (<= (+ (* x0 x0) (* y0 y0)) 4))
|
||||
(let x1 (+ (- (* x0 x0) (* y0 y0)) x))
|
||||
(let y1 (+ (* 2 x0 y0) y))
|
||||
(= x0 x1)
|
||||
(= y0 y1)
|
||||
(= iter (+ iter 1))
|
||||
)
|
||||
(print iter)
|
||||
(= xpixel (+ xpixel 1))
|
||||
)
|
||||
(= ypixel (+ ypixel 1))
|
||||
)
|
||||
)
|
||||
Loading…
Reference in New Issue