Initial commit

rxi committed 7 years ago

Commit a83bc97No parent (first commit)9 files · +1461 −0Browse files

Unified · Split

9 files

LICENSE +19 −0
README.md +42 −0
doc/impl.md +155 −0
doc/lang.md +143 −0
fe.c +884 −0
fe.h +61 −0
scripts/fib.fe +10 −0
scripts/life.fe +112 −0
scripts/mandelbrot.fe +35 −0

@@ -0,0 +1,19 @@
	1	Copyright (c) 2019 rxi
	2
	3	Permission is hereby granted, free of charge, to any person obtaining a copy of
	4	this software and associated documentation files (the "Software"), to deal in
	5	the Software without restriction, including without limitation the rights to
	6	use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
	7	of the Software, and to permit persons to whom the Software is furnished to do
	8	so, subject to the following conditions:
	9
	10	The above copyright notice and this permission notice shall be included in all
	11	copies or substantial portions of the Software.
	12
	13	THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
	14	IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
	15	FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
	16	AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
	17	LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
	18	OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
	19	SOFTWARE.

README.md+42−0

@@ -0,0 +1,42 @@
	1	# fe
	2	A tiny, embeddable language implemented in ANSI C
	3
	4	```clojure
	5	(= reverse (fn (lst)
	6	(let res nil)
	7	(while lst
	8	(= res (cons (car lst) res))
	9	(= lst (cdr lst))
	10	)
	11	res
	12	))
	13
	14	(= animals '("cat" "dog" "fox"))
	15
	16	(print (reverse animals)) ; => ("fox" "dog" "cat")
	17	```
	18
	19	## Overview
	20	* Supports numbers, symbols, strings, pairs, lambdas, macros
	21	* Lexically scoped variables, closures
	22	* Small memory usage within a fixed-sized memory region — no mallocs
	23	* Simple mark and sweep garbage collector
	24	* Easy to use C API
	25	* Portable ANSI C — works on 32 and 64bit
	26	* Concise — less than 800 sloc
	27
	28	---
	29
	30	* [Demo Scripts](scripts)
	31	* [Language Overview](doc/lang.md)
	32	* [Implementation Overview](doc/impl.md)
	33
	34
	35	## Contributing
	36	The library focuses on being lightweight and minimal; pull requests will
	37	likely not be merged. Bug reports and questions are welcome.
	38
	39
	40	## License
	41	This library is free software; you can redistribute it and/or modify it under
	42	the terms of the MIT license. See [LICENSE](LICENSE) for details.

doc/impl.md+155−0

@@ -0,0 +1,155 @@
	1
	2	# Implementation
	3
	4	## Overview
	5	The implementation aims to fulfill the following goals:
	6	* Small memory usage within a fixed-sized memory region — no mallocs
	7	* Practical for small scripts (extension scripts, config files)
	8	* Concise source — less than 1000 loc
	9	* Portable ANSI C (Windows, Linux, DOS — 32 and 64bit)
	10	* Simple and easy to understand source
	11	* Simple and easy to use C API
	12
	13	The language offers the following:
	14	* Numbers, symbols, strings, pairs, lambdas, macros, cfuncs, ptrs
	15	* Lexically scoped variables
	16	* Closures
	17	* Variadic functions
	18	* Mark and sweep garbage collector
	19	* Stack traceback on error
	20
	21
	22	## Memory
	23	The implementation uses a fixed-sized region of memory supplied by the user when
	24	creating the `context`. The implementation stores the `context` at the start of
	25	this memory region and uses the rest of the region to store `object`s.
	26
	27
	28	## Objects
	29	All data is stored in fixed-sized `object`s. Each `object` consists of a `car`
	30	and `cdr`. The lowest bit of an `object`'s `car` stores type information — if
	31	the `object` is a `PAIR` (cons cell) the lowest bit is `0`, otherwise it is `1`.
	32	The second-lowest bit is used by the garbage collector to mark the object and is
	33	always `0` outside of the `collectgarbage()` function.
	34
	35	Pairs use the `car` and `cdr` as pointers to other `object`s. As all
	36	`object`s are at least 4byte-aligned we can always assume the lower two
	37	bits on a pointer referencing an `object` are `0`.
	38
	39	Non-pair `object`s store their full type in the first byte of `car`.
	40
	41	##### String
	42	Strings are stored using multiple `object`s of type `STRING` linked together —
	43	each string `object` stores a part of the string in the bytes of `car` not used
	44	by the type and gc mark. The `cdr` stores the `object` with the next part of
	45	the string or `nil` if this was the last part of the string.
	46
	47	##### Symbol
	48	Symbols store a pair object in the `cdr`; the `car` of this pair contains a
	49	`string` object, the `cdr` part contains the globally bound value for the
	50	symbol. Symbols are interned.
	51
	52	##### Number
	53	Numbers store a `Number` in the `cdr` part of the `object`. By default
	54	`Number` is a `float`, but any value can be used so long as it is equal
	55	or smaller in size than an `object` pointer. If a different type of
	56	value is used, `lsp_read()` and `lsp_write()` must also be updated to
	57	handle the new type correctly.
	58
	59	##### Prim
	60	Primitives (built-ins) store an enum in the `cdr` part of the `object`.
	61
	62	##### CFunc
	63	CFuncs store a `CFunc` pointer in the `cdr` part of the `object`.
	64
	65	##### Ptr
	66	Ptrs store a `void` pointer in the `cdr` part of the `object`. The handler
	67	functions `gc` and `mark` are called whenever a `ptr` is collected or marked by
	68	the garbage collector — the set `lsp_CFunc` is passed the object itself in place
	69	of an arguments list.
	70
	71
	72	## Environments
	73	Environments are stored as association lists, for example: an environment with
	74	the symbol `x` bound to `10` and `y` bound to `20` would be
	75	`((x . 10) (y . 20))`. Globally bound values are stored directly in the `symbol`
	76	object.
	77
	78
	79	## Macros
	80	Macros work similar to functions, but receive their arguments unevaluated and
	81	return code which is evaluated in the scope of the caller. The first time a
	82	macro is called the code which called it is replaced by the generated code, such
	83	that the macro itself is only ran once in each place it is called. For example,
	84	we could define the following macro to increment a value by one:
	85
	86	```clojure
	87	(= incr
	88	(mac (sym)
	89	(list '= sym (list '+ sym 1))))
	90	```
	91
	92	And use it in the following while loop:
	93
	94	```clojure
	95	(= i 0)
	96	(while (< i 0)
	97	(print i)
	98	(incr i))
	99	```
	100
	101	Upon the first call to `incr`, the program code would be modified in-place,
	102	replacing the call to the macro with the code it generated:
	103
	104	```clojure
	105	(= i 0)
	106	(while (< i 0)
	107	(print i)
	108	(= i (+ i 1)))
	109	```
	110
	111	Subsequent iterations of the loop would run the new code which now exists where
	112	the macro call was originally.
	113
	114
	115	## Garbage Collection
	116	A simple mark-and-sweep garbage collector is used in conjunction with a
	117	`freelist`. When the `context` is initialized a `freelist` is created from all
	118	the `object`s. When an `object` is required it is popped from the `freelist`. If
	119	there are no more `object`s on the `freelist` the garbage collector does a full
	120	mark-and-sweep, pushing unreachable `object`s back to the `freelist`, thus
	121	garbage collection may occur whenever a new `object` is created.
	122
	123	The `context` maintains a `gcstack` — this is used to protect `object`s which
	124	may not be reachable from being collected. These may include, for example:
	125	`object`s returned after an eval, or a list which is currently being constructed
	126	from multiple pairs. Newly created `object`s are automatically pushed to this
	127	stack.
	128
	129
	130	## Error Handling
	131	If an error occurs the `lsp_error()` function is called — this function resets
	132	the `context` to a safe state and calls the `error` handler if one is set. The
	133	error handler function is passed the error message and list representing the
	134	call stack (both these values are valid only for this function). The error
	135	handler can be safely longjmp'd out of to recover from the error and use of the
	136	`context` can continue — this can be seen in the REPL. New `object`s should not
	137	be created from inside the error handler.
	138
	139	If no error handler is set or if the error handler returns then the error
	140	message and callstack are printed to `stderr` and `exit` is called with the
	141	value `EXIT_FAILURE`.
	142
	143
	144	## Known Issues
	145	The implementation has some known issues; these exist as a side effect of trying
	146	to keep the implementation terse, but should not hinder normal usage:
	147
	148	* The garbage collector recurses on the `CAR` of objects thus deeply nested
	149	`CAR`s may overflow the C stack — an object's `CDR` is looped on and will not
	150	overflow the stack
	151	* The storage of an object's type and GC mark assumes a little-endian system and
	152	will not work correctly on systems of other endianness
	153	* Proper tailcalls are not implemented — `while` can be used for iterating over
	154	lists
	155	* Strings are null-terminated and therefor not binary safe

doc/lang.md+143−0

@@ -0,0 +1,143 @@
	1	# Language
	2
	3	## Forms
	4
	5	### Special-forms
	6	##### (let sym val)
	7	Creates a new binding of `sym` to the value `val` in the current environment.
	8
	9	##### (= sym val)
	10	Sets the existing binding of `sym` to the value `val`; in lieu of an
	11	existing binding the global value is set.
	12
	13	##### (if cond then else ...)
	14	If `cond` is true evaluates `then`, else evaluates `else` — `else` and `then`
	15	statements can be chained to replicate the functionality of else-if blocks.
	16
	17	```clojure
	18	> (= x 2)
	19	nil
	20	> (if (is x 1) "one"
	21	(is x 2) "two"
	22	(is x 3) "three"
	23	"?")
	24	two
	25	```
	26
	27	##### (fn params ...)
	28	Creates a new function.
	29
	30	```clojure
	31	> (= sqr (fn (n) (* n n)))
	32	nil
	33	> (sqr 4)
	34	16
	35	```
	36
	37	##### (mac params ...)
	38	Creates a new macro.
	39	```clojure
	40	> (= incr (mac (x) (list '= x (list '+ x 1))))
	41	nil
	42	> (= n 0)
	43	nil
	44	> (incr n)
	45	nil
	46	> n
	47	1
	48	```
	49
	50	##### (while cond ...)
	51	If `cond` evaluates to true evaluates the rest of its arguments and keeps
	52	repeating until `cond` evaluates to `nil`.
	53
	54	```clojure
	55	> (= i 0)
	56	nil
	57	> (while (< i 3)
	58	(print i)
	59	(= i (+ i 1)))
	60	0
	61	1
	62	2
	63	nil
	64	```
	65
	66	##### (quote val)
	67	Returns `val` unevaluated.
	68
	69	```clojure
	70	> (quote (hello world))
	71	(hello world)
	72	```
	73
	74	##### (and ...)
	75	Evaluates each argument until one results in `nil` — the last argument's value
	76	is returned if all the arguments are true.
	77
	78	##### (or ...)
	79	Evaluates each argument until one results in true, in which case that arguments
	80	value is returned — `nil` is returned if no arguments are true.
	81
	82	##### (do ...)
	83	Evaluates each of its arguments and returns the value of the last one.
	84
	85	### Functions
	86	##### (cons car cdr)
	87	Creates a new pair with the given `car` and `cdr` values.
	88
	89	##### (car pair)
	90	Returns the `car` of the `pair` or `nil` if `pair` is `nil`.
	91
	92	##### (cdr pair)
	93	Returns the `cdr` of the `pair` or `nil` if `pair` is `nil`.
	94
	95	##### (setcar pair val)
	96	Sets the `car` of `pair` to `val`.
	97
	98	##### (setcdr pair val)
	99	Sets the `cdr` of `pair` to `val`.
	100
	101	##### (list ...)
	102	Returns all its arguments as a list.
	103	```clojure
	104	> (list 1 2 3)
	105	(1 2 3)
	106	```
	107
	108	##### (not val)
	109	Returns true if `val` is `nil`, else returns `nil`
	110	```clojure
	111	> (not 1)
	112	nil
	113	```
	114
	115	##### (is a b)
	116	Returns true if the values `a` and `b` are equal in value. Numbers and strings
	117	are equal if equivalent, all other values are equal only if it is the same
	118	underlying object.
	119
	120	##### (atom x)
	121	Returns true if `x` is not a pair, otherwise `nil`.
	122
	123	##### (print ...)
	124	Prints all it's arguments to `stdout`, each separated by a space and followed by
	125	a new line.
	126
	127	##### (< a b)
	128	Returns true if the numerical value `a` is less than `b`.
	129
	130	##### (<= a b)
	131	Returns true if the numerical value `a` is less than or equal to `b`.
	132
	133	##### (+ ...)
	134	Adds all its arguments together.
	135
	136	##### (- ...)
	137	Subtracts all its arguments, left-to-right.
	138
	139	##### (* ...)
	140	Multiplies all its arguments.
	141
	142	##### (/ ...)
	143	Divides all its arguments, left-to-right.

fe.c+884−0

@@ -0,0 +1,884 @@
	1	/*
	2	** Copyright (c) 2019 rxi
	3	**
	4	** Permission is hereby granted, free of charge, to any person obtaining a copy
	5	** of this software and associated documentation files (the "Software"), to
	6	** deal in the Software without restriction, including without limitation the
	7	** rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
	8	** sell copies of the Software, and to permit persons to whom the Software is
	9	** furnished to do so, subject to the following conditions:
	10	**
	11	** The above copyright notice and this permission notice shall be included in
	12	** all copies or substantial portions of the Software.
	13	**
	14	** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
	15	** IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
	16	** FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
	17	** AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
	18	** LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
	19	** FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
	20	** IN THE SOFTWARE.
	21	*/
	22
	23	#include <string.h>
	24	#include "fe.h"
	25
	26	#define unused(x) ( (void) (x) )
	27	#define car(x) ( (x)->car.o )
	28	#define cdr(x) ( (x)->cdr.o )
	29	#define tag(x) ( (x)->car.c )
	30	#define isnil(x) ( (x) == &nil )
	31	#define type(x) ( tag(x) & 0x1 ? tag(x) >> 2 : FE_TPAIR )
	32	#define settype(x,t) ( tag(x) = (t) << 2 \| 1 )
	33	#define number(x) ( (x)->cdr.n )
	34	#define prim(x) ( (x)->cdr.c )
	35	#define cfunc(x) ( (x)->cdr.f )
	36	#define strbuf(x) ( &(x)->car.c + 1 )
	37
	38	#define STRBUFSIZE ( (int) sizeof(fe_Object*) - 1 )
	39	#define GCMARKBIT ( 0x2 )
	40	#define GCSTACKSIZE ( 256 )
	41
	42
	43	enum {
	44	P_LET, P_SET, P_IF, P_FN, P_MAC, P_WHILE, P_QUOTE, P_AND, P_OR, P_DO, P_CONS,
	45	P_CAR, P_CDR, P_SETCAR, P_SETCDR, P_LIST, P_NOT, P_IS, P_ATOM, P_PRINT, P_LT,
	46	P_LTE, P_ADD, P_SUB, P_MUL, P_DIV, P_MAX
	47	};
	48
	49	static const char *primnames[] = {
	50	"let", "=", "if", "fn", "mac", "while", "quote", "and", "or", "do", "cons",
	51	"car", "cdr", "setcar", "setcdr", "list", "not", "is", "atom", "print", "<",
	52	"<=", "+", "-", "*", "/"
	53	};
	54
	55	static const char *typenames[] = {
	56	"pair", "free", "nil", "number", "symbol", "string",
	57	"func", "macro", "prim", "cfunc", "ptr"
	58	};
	59
	60	typedef union { fe_Object *o; fe_CFunc f; fe_Number n; char c; } Value;
	61
	62	struct fe_Object { Value car, cdr; };
	63
	64	struct fe_Context {
	65	fe_Handlers handlers;
	66	fe_Object *gcstack[GCSTACKSIZE];
	67	int gcstack_idx;
	68	fe_Object *objects;
	69	int object_count;
	70	fe_Object *calllist;
	71	fe_Object *freelist;
	72	fe_Object *symlist;
	73	fe_Object *t;
	74	int nextchr;
	75	};
	76
	77	static fe_Object nil = {{ (void*) (FE_TNIL << 2 \| 1) }, { NULL }};
	78
	79
	80	fe_Handlers* fe_handlers(fe_Context *ctx) {
	81	return &ctx->handlers;
	82	}
	83
	84
	85	void fe_error(fe_Context ctx, const char msg) {
	86	fe_Object *cl = ctx->calllist;
	87	/* reset context state */
	88	ctx->calllist = &nil;
	89	/* do error handler */
	90	if (ctx->handlers.error) { ctx->handlers.error(ctx, msg, cl); }
	91	/* error handler returned -- print error and traceback, exit */
	92	fprintf(stderr, "error: %s\n", msg);
	93	for (; !isnil(cl); cl = cdr(cl)) {
	94	char buf[64];
	95	fe_tostring(ctx, car(cl), buf, sizeof(buf));
	96	fprintf(stderr, "=> %s\n", buf);
	97	}
	98	exit(EXIT_FAILURE);
	99	}
	100
	101
	102	fe_Object* fe_nextarg(fe_Context ctx, fe_Object *arg) {
	103	fe_Object a = arg;
	104	if (type(a) != FE_TPAIR) {
	105	if (isnil(a)) { fe_error(ctx, "too few arguments"); }
	106	fe_error(ctx, "dotted pair in argument list");
	107	}
	108	*arg = cdr(a);
	109	return car(a);
	110	}
	111
	112
	113	static fe_Object* checktype(fe_Context ctx, fe_Object obj, int type) {
	114	char buf[64];
	115	if (type(obj) != type) {
	116	sprintf(buf, "expected %s, got %s", typenames[type], typenames[type(obj)]);
	117	fe_error(ctx, buf);
	118	}
	119	return obj;
	120	}
	121
	122
	123	int fe_type(fe_Context ctx, fe_Object obj) {
	124	unused(ctx);
	125	return type(obj);
	126	}
	127
	128
	129	int fe_isnil(fe_Context ctx, fe_Object obj) {
	130	unused(ctx);
	131	return isnil(obj);
	132	}
	133
	134
	135	void fe_pushgc(fe_Context ctx, fe_Object obj) {
	136	if (ctx->gcstack_idx == GCSTACKSIZE) {
	137	fe_error(ctx, "gc stack overflow");
	138	}
	139	ctx->gcstack[ctx->gcstack_idx++] = obj;
	140	}
	141
	142
	143	void fe_restoregc(fe_Context *ctx, int idx) {
	144	ctx->gcstack_idx = idx;
	145	}
	146
	147
	148	int fe_savegc(fe_Context *ctx) {
	149	return ctx->gcstack_idx;
	150	}
	151
	152
	153	void fe_mark(fe_Context ctx, fe_Object obj) {
	154	fe_Object *car;
	155	begin:
	156	if (tag(obj) & GCMARKBIT) { return; }
	157	car = car(obj); /* store car before modifying it with GCMARKBIT */
	158	tag(obj) \|= GCMARKBIT;
	159
	160	switch (type(obj)) {
	161	case FE_TPAIR:
	162	fe_mark(ctx, car);
	163	/* fall through */
	164	case FE_TFUNC: case FE_TMACRO: case FE_TSYMBOL: case FE_TSTRING:
	165	obj = cdr(obj);
	166	goto begin;
	167
	168	case FE_TPTR:
	169	if (ctx->handlers.mark) { ctx->handlers.mark(ctx, obj); }
	170	break;
	171	}
	172	}
	173
	174
	175	static void collectgarbage(fe_Context *ctx) {
	176	int i;
	177	/* mark */
	178	for (i = 0; i < ctx->gcstack_idx; i++) {
	179	fe_mark(ctx, ctx->gcstack[i]);
	180	}
	181	fe_mark(ctx, ctx->symlist);
	182	/* sweep and unmark */
	183	for (i = 0; i < ctx->object_count; i++) {
	184	fe_Object *obj = &ctx->objects[i];
	185	if (type(obj) == FE_TFREE) { continue; }
	186	if (~tag(obj) & GCMARKBIT) {
	187	if (type(obj) == FE_TPTR && ctx->handlers.gc) {
	188	ctx->handlers.gc(ctx, obj);
	189	}
	190	settype(obj, FE_TFREE);
	191	cdr(obj) = ctx->freelist;
	192	ctx->freelist = obj;
	193	} else {
	194	tag(obj) &= ~GCMARKBIT;
	195	}
	196	}
	197	}
	198
	199
	200	static int equal(fe_Object a, fe_Object b) {
	201	if (a == b) { return 1; }
	202	if (type(a) != type(b)) { return 0; }
	203	if (type(a) == FE_TNUMBER) { return number(a) == number(b); }
	204	if (type(a) == FE_TSTRING) {
	205	for (; !isnil(a) && !isnil(b); a = cdr(a), b = cdr(b)) {
	206	if (car(a) != car(b)) { return 0; }
	207	}
	208	return isnil(a) && isnil(b);
	209	}
	210	return 0;
	211	}
	212
	213
	214	static int streq(fe_Object obj, const char str) {
	215	while (!isnil(obj)) {
	216	int i;
	217	for (i = 0; i < STRBUFSIZE; i++) {
	218	if (strbuf(obj)[i] != *str) { return 0; }
	219	if (*str) { str++; }
	220	}
	221	obj = cdr(obj);
	222	}
	223	return *str == '\0';
	224	}
	225
	226
	227	static fe_Object* object(fe_Context *ctx) {
	228	fe_Object *obj;
	229	/* do gc if freelist has no more objects */
	230	if (isnil(ctx->freelist)) {
	231	collectgarbage(ctx);
	232	if (isnil(ctx->freelist)) { fe_error(ctx, "out of memory"); }
	233	}
	234	/* get object from freelist and push to the gcstack */
	235	obj = ctx->freelist;
	236	ctx->freelist = cdr(obj);
	237	fe_pushgc(ctx, obj);
	238	return obj;
	239	}
	240
	241
	242	fe_Object* fe_cons(fe_Context ctx, fe_Object car, fe_Object *cdr) {
	243	fe_Object *obj = object(ctx);
	244	car(obj) = car;
	245	cdr(obj) = cdr;
	246	return obj;
	247	}
	248
	249
	250	fe_Object* fe_bool(fe_Context *ctx, int b) {
	251	return b ? ctx->t : &nil;
	252	}
	253
	254
	255	fe_Object* fe_number(fe_Context *ctx, fe_Number n) {
	256	fe_Object *obj = object(ctx);
	257	settype(obj, FE_TNUMBER);
	258	number(obj) = n;
	259	return obj;
	260	}
	261
	262
	263	static fe_Object* buildstring(fe_Context ctx, fe_Object tail, int chr) {
	264	if (!tail \|\| strbuf(tail)[STRBUFSIZE - 1] != '\0') {
	265	fe_Object *obj = fe_cons(ctx, NULL, &nil);
	266	settype(obj, FE_TSTRING);
	267	if (tail) {
	268	cdr(tail) = obj;
	269	ctx->gcstack_idx--;
	270	}
	271	tail = obj;
	272	}
	273	strbuf(tail)[strlen(strbuf(tail))] = chr;
	274	return tail;
	275	}
	276
	277
	278	fe_Object* fe_string(fe_Context ctx, const char str) {
	279	fe_Object *obj = buildstring(ctx, NULL, '\0');
	280	fe_Object *tail = obj;
	281	while (*str) {
	282	tail = buildstring(ctx, tail, *str++);
	283	}
	284	return obj;
	285	}
	286
	287
	288	fe_Object* fe_symbol(fe_Context ctx, const char name) {
	289	fe_Object *obj;
	290	/* try to find in symlist */
	291	for (obj = ctx->symlist; !isnil(obj); obj = cdr(obj)) {
	292	if (streq(car(cdr(car(obj))), name)) {
	293	return car(obj);
	294	}
	295	}
	296	/* create new object, push to symlist and return */
	297	obj = object(ctx);
	298	settype(obj, FE_TSYMBOL);
	299	cdr(obj) = fe_cons(ctx, fe_string(ctx, name), &nil);
	300	ctx->symlist = fe_cons(ctx, obj, ctx->symlist);
	301	return obj;
	302	}
	303
	304
	305	fe_Object* fe_cfunc(fe_Context *ctx, fe_CFunc fn) {
	306	fe_Object *obj = object(ctx);
	307	settype(obj, FE_TCFUNC);
	308	cfunc(obj) = fn;
	309	return obj;
	310	}
	311
	312
	313	fe_Object* fe_ptr(fe_Context ctx, void ptr) {
	314	fe_Object *obj = object(ctx);
	315	settype(obj, FE_TPTR);
	316	cdr(obj) = ptr;
	317	return obj;
	318	}
	319
	320
	321	fe_Object* fe_list(fe_Context ctx, fe_Object *objs, int n) {
	322	fe_Object *res = &nil;
	323	while (n--) {
	324	res = fe_cons(ctx, objs[n], res);
	325	}
	326	return res;
	327	}
	328
	329
	330	fe_Object* fe_car(fe_Context ctx, fe_Object obj) {
	331	if (isnil(obj)) { return obj; }
	332	return car(checktype(ctx, obj, FE_TPAIR));
	333	}
	334
	335
	336	fe_Object* fe_cdr(fe_Context ctx, fe_Object obj) {
	337	if (isnil(obj)) { return obj; }
	338	return cdr(checktype(ctx, obj, FE_TPAIR));
	339	}
	340
	341
	342	static void writestr(fe_Context ctx, fe_WriteFn fn, void udata, const char *s) {
	343	while (s) { fn(ctx, udata, s++); }
	344	}
	345
	346	void fe_write(fe_Context ctx, fe_Object obj, fe_WriteFn fn, void *udata, int qt) {
	347	char buf[32];
	348
	349	switch (type(obj)) {
	350	case FE_TNIL:
	351	writestr(ctx, fn, udata, "nil");
	352	break;
	353
	354	case FE_TNUMBER:
	355	sprintf(buf, "%.7g", number(obj));
	356	writestr(ctx, fn, udata, buf);
	357	break;
	358
	359	case FE_TPAIR:
	360	fn(ctx, udata, '(');
	361	for (;;) {
	362	fe_write(ctx, car(obj), fn, udata, 1);
	363	obj = cdr(obj);
	364	if (type(obj) != FE_TPAIR) { break; }
	365	fn(ctx, udata, ' ');
	366	}
	367	if (!isnil(obj)) {
	368	writestr(ctx, fn, udata, " . ");
	369	fe_write(ctx, obj, fn, udata, 1);
	370	}
	371	fn(ctx, udata, ')');
	372	break;
	373
	374	case FE_TSYMBOL:
	375	fe_write(ctx, car(cdr(obj)), fn, udata, 0);
	376	break;
	377
	378	case FE_TSTRING:
	379	if (qt) { fn(ctx, udata, '"'); }
	380	while (!isnil(obj)) {
	381	int i;
	382	for (i = 0; i < STRBUFSIZE && strbuf(obj)[i]; i++) {
	383	if (qt && strbuf(obj)[i] == '"') { fn(ctx, udata, '\\'); }
	384	fn(ctx, udata, strbuf(obj)[i]);
	385	}
	386	obj = cdr(obj);
	387	}
	388	if (qt) { fn(ctx, udata, '"'); }
	389	break;
	390
	391	default:
	392	sprintf(buf, "[%s %p]", typenames[type(obj)], (void*) obj);
	393	writestr(ctx, fn, udata, buf);
	394	break;
	395	}
	396	}
	397
	398
	399	static void writefp(fe_Context ctx, void udata, char chr) {
	400	unused(ctx);
	401	fputc(chr, udata);
	402	}
	403
	404	void fe_writefp(fe_Context ctx, fe_Object obj, FILE *fp) {
	405	fe_write(ctx, obj, writefp, fp, 0);
	406	}
	407
	408
	409	typedef struct { char *p; int n; } CharPtrInt;
	410
	411	static void writebuf(fe_Context ctx, void udata, char chr) {
	412	CharPtrInt *x = udata;
	413	unused(ctx);
	414	if (x->n) { *x->p++ = chr; x->n--; }
	415	}
	416
	417	int fe_tostring(fe_Context ctx, fe_Object obj, char *dst, int size) {
	418	CharPtrInt x;
	419	x.p = dst;
	420	x.n = size - 1;
	421	fe_write(ctx, obj, writebuf, &x, 0);
	422	*x.p = '\0';
	423	return size - x.n - 1;
	424	}
	425
	426
	427	fe_Number fe_tonumber(fe_Context ctx, fe_Object obj) {
	428	return number(checktype(ctx, obj, FE_TNUMBER));
	429	}
	430
	431
	432	void* fe_toptr(fe_Context ctx, fe_Object obj) {
	433	return cdr(checktype(ctx, obj, FE_TPTR));
	434	}
	435
	436
	437	static fe_Object* getbound(fe_Object sym, fe_Object env) {
	438	/* try to find in environment */
	439	for (; !isnil(env); env = cdr(env)) {
	440	fe_Object *x = car(env);
	441	if (car(x) == sym) { return x; }
	442	}
	443	/* return global */
	444	return cdr(sym);
	445	}
	446
	447
	448	void fe_set(fe_Context ctx, fe_Object sym, fe_Object *v) {
	449	unused(ctx);
	450	cdr(getbound(sym, &nil)) = v;
	451	}
	452
	453
	454	static fe_Object rparen;
	455
	456	static fe_Object* read_(fe_Context ctx, fe_ReadFn fn, void udata) {
	457	const char *delimiter = " \n\t\r();";
	458	fe_Object v, res, **tail;
	459	fe_Number n;
	460	int chr, gc;
	461	char buf[64], *p;
	462
	463	/* get next character */
	464	chr = ctx->nextchr ? ctx->nextchr : fn(ctx, udata);
	465	ctx->nextchr = '\0';
	466
	467	/* skip whitespace */
	468	while (chr && strchr(" \n\t\r", chr)) {
	469	chr = fn(ctx, udata);
	470	}
	471
	472	switch (chr) {
	473	case '\0':
	474	return NULL;
	475
	476	case ';':
	477	while (chr && chr != '\n') { chr = fn(ctx, udata); }
	478	return read_(ctx, fn, udata);
	479
	480	case ')':
	481	return &rparen;
	482
	483	case '(':
	484	res = &nil;
	485	tail = &res;
	486	gc = fe_savegc(ctx);
	487	fe_pushgc(ctx, res); /* to cause error on too-deep nesting */
	488	while ( (v = read_(ctx, fn, udata)) != &rparen ) {
	489	if (v == NULL) { fe_error(ctx, "unclosed list"); }
	490	if (type(v) == FE_TSYMBOL && streq(car(cdr(v)), ".")) {
	491	/* dotted pair */
	492	*tail = fe_read(ctx, fn, udata);
	493	} else {
	494	/* proper pair */
	495	*tail = fe_cons(ctx, v, &nil);
	496	tail = &cdr(*tail);
	497	}
	498	fe_restoregc(ctx, gc);
	499	fe_pushgc(ctx, res);
	500	}
	501	return res;
	502
	503	case '\'':
	504	v = fe_read(ctx, fn, udata);
	505	if (!v) { fe_error(ctx, "stray '''"); }
	506	return fe_cons(ctx, fe_symbol(ctx, "quote"), fe_cons(ctx, v, &nil));
	507
	508	case '"':
	509	res = buildstring(ctx, NULL, '\0');
	510	v = res;
	511	chr = fn(ctx, udata);
	512	while (chr != '"') {
	513	if (chr == '\0') { fe_error(ctx, "unclosed string"); }
	514	if (chr == '\\') {
	515	chr = fn(ctx, udata);
	516	if (strchr("nrt", chr)) { chr = strchr("n\nr\rt\t", chr)[1]; }
	517	}
	518	v = buildstring(ctx, v, chr);
	519	chr = fn(ctx, udata);
	520	}
	521	return res;
	522
	523	default:
	524	p = buf;
	525	do {
	526	if (p == buf + sizeof(buf) - 1) { fe_error(ctx, "symbol too long"); }
	527	*p++ = chr;
	528	chr = fn(ctx, udata);
	529	} while (chr && !strchr(delimiter, chr));
	530	*p = '\0';
	531	ctx->nextchr = chr;
	532	n = strtod(buf, &p); /* try to read as number */
	533	if (p != buf && strchr(delimiter, *p)) { return fe_number(ctx, n); }
	534	if (!strcmp(buf, "nil")) { return &nil; }
	535	return fe_symbol(ctx, buf);
	536	}
	537	}
	538
	539
	540	fe_Object* fe_read(fe_Context ctx, fe_ReadFn fn, void udata) {
	541	fe_Object* obj = read_(ctx, fn, udata);
	542	if (obj == &rparen) { fe_error(ctx, "stray ')'"); }
	543	return obj;
	544	}
	545
	546
	547	static char readfp(fe_Context ctx, void udata) {
	548	int chr;
	549	unused(ctx);
	550	return (chr = fgetc(udata)) == EOF ? '\0' : chr;
	551	}
	552
	553	fe_Object* fe_readfp(fe_Context ctx, FILE fp) {
	554	return fe_read(ctx, readfp, fp);
	555	}
	556
	557
	558	static fe_Object* eval(fe_Context ctx, fe_Object obj, fe_Object env, fe_Object *bind);
	559
	560	static fe_Object* evallist(fe_Context ctx, fe_Object lst, fe_Object *env) {
	561	fe_Object *res = &nil;
	562	fe_Object **tail = &res;
	563	while (!isnil(lst)) {
	564	*tail = fe_cons(ctx, eval(ctx, fe_nextarg(ctx, &lst), env, NULL), &nil);
	565	tail = &cdr(*tail);
	566	}
	567	return res;
	568	}
	569
	570
	571	static fe_Object* dolist(fe_Context ctx, fe_Object lst, fe_Object *env) {
	572	fe_Object *res = &nil;
	573	int save = fe_savegc(ctx);
	574	while (!isnil(lst)) {
	575	fe_restoregc(ctx, save);
	576	fe_pushgc(ctx, env);
	577	res = eval(ctx, fe_nextarg(ctx, &lst), env, &env);
	578	}
	579	return res;
	580	}
	581
	582
	583	static fe_Object* argstoenv(fe_Context ctx, fe_Object prm, fe_Object arg, fe_Object env) {
	584	while (!isnil(prm)) {
	585	if (type(prm) != FE_TPAIR) {
	586	env = fe_cons(ctx, fe_cons(ctx, prm, arg), env);
	587	break;
	588	}
	589	env = fe_cons(ctx, fe_cons(ctx, car(prm), fe_car(ctx, arg)), env);
	590	prm = cdr(prm);
	591	arg = fe_cdr(ctx, arg);
	592	}
	593	return env;
	594	}
	595
	596
	597	#define evalarg() eval(ctx, fe_nextarg(ctx, &arg), env, NULL)
	598
	599	#define arithop(op) { \
	600	fe_Number x = fe_tonumber(ctx, evalarg()); \
	601	while (!isnil(arg)) { \
	602	x = x op fe_tonumber(ctx, evalarg()); \
	603	} \
	604	res = fe_number(ctx, x); \
	605	}
	606
	607	#define numcmpop(op) { \
	608	va = checktype(ctx, evalarg(), FE_TNUMBER); \
	609	vb = checktype(ctx, evalarg(), FE_TNUMBER); \
	610	res = fe_bool(ctx, number(va) op number(vb)); \
	611	}
	612
	613
	614	static fe_Object* eval(fe_Context ctx, fe_Object obj, fe_Object env, fe_Object *newenv) {
	615	fe_Object fn, arg, *res;
	616	fe_Object cl, va, vb;
	617	int n, gc;
	618
	619	switch (type(obj)) {
	620	case FE_TSYMBOL: return cdr(getbound(obj, env));
	621	case FE_TPAIR: break;
	622	default: return obj;
	623	}
	624
	625	car(&cl) = obj, cdr(&cl) = ctx->calllist;
	626	ctx->calllist = &cl;
	627
	628	gc = fe_savegc(ctx);
	629	fn = eval(ctx, car(obj), env, NULL);
	630	arg = cdr(obj);
	631	res = &nil;
	632
	633	switch (type(fn)) {
	634	case FE_TPRIM:
	635	switch (prim(fn)) {
	636	case P_LET:
	637	va = checktype(ctx, fe_nextarg(ctx, &arg), FE_TSYMBOL);
	638	if (newenv) {
	639	*newenv = fe_cons(ctx, fe_cons(ctx, va, evalarg()), env);
	640	}
	641	break;
	642
	643	case P_SET:
	644	va = checktype(ctx, fe_nextarg(ctx, &arg), FE_TSYMBOL);
	645	cdr(getbound(va, env)) = evalarg();
	646	break;
	647
	648	case P_IF:
	649	while (!isnil(arg)) {
	650	va = evalarg();
	651	if (!isnil(va)) {
	652	res = isnil(arg) ? va : evalarg();
	653	break;
	654	}
	655	if (isnil(arg)) { break; }
	656	arg = cdr(arg);
	657	}
	658	break;
	659
	660	case P_FN: case P_MAC:
	661	va = fe_cons(ctx, env, arg);
	662	fe_nextarg(ctx, &arg);
	663	res = object(ctx);
	664	settype(res, prim(fn) == P_FN ? FE_TFUNC : FE_TMACRO);
	665	cdr(res) = va;
	666	break;
	667
	668	case P_WHILE:
	669	va = fe_nextarg(ctx, &arg);
	670	n = fe_savegc(ctx);
	671	while (!isnil(eval(ctx, va, env, NULL))) {
	672	dolist(ctx, arg, env);
	673	fe_restoregc(ctx, n);
	674	}
	675	break;
	676
	677	case P_QUOTE:
	678	res = fe_nextarg(ctx, &arg);
	679	break;
	680
	681	case P_AND:
	682	while (!isnil(arg) && !isnil(res = evalarg()));
	683	break;
	684
	685	case P_OR:
	686	while (!isnil(arg) && isnil(res = evalarg()));
	687	break;
	688
	689	case P_DO:
	690	res = dolist(ctx, arg, env);
	691	break;
	692
	693	case P_CONS:
	694	va = evalarg();
	695	res = fe_cons(ctx, va, evalarg());
	696	break;
	697
	698	case P_CAR:
	699	res = fe_car(ctx, evalarg());
	700	break;
	701
	702	case P_CDR:
	703	res = fe_cdr(ctx, evalarg());
	704	break;
	705
	706	case P_SETCAR:
	707	va = checktype(ctx, evalarg(), FE_TPAIR);
	708	car(va) = evalarg();
	709	break;
	710
	711	case P_SETCDR:
	712	va = checktype(ctx, evalarg(), FE_TPAIR);
	713	cdr(va) = evalarg();
	714	break;
	715
	716	case P_LIST:
	717	res = evallist(ctx, arg, env);
	718	break;
	719
	720	case P_NOT:
	721	res = fe_bool(ctx, isnil(evalarg()));
	722	break;
	723
	724	case P_IS:
	725	va = evalarg();
	726	res = fe_bool(ctx, equal(va, evalarg()));
	727	break;
	728
	729	case P_ATOM:
	730	res = fe_bool(ctx, fe_type(ctx, evalarg()) != FE_TPAIR);
	731	break;
	732
	733	case P_PRINT:
	734	while (!isnil(arg)) {
	735	fe_writefp(ctx, evalarg(), stdout);
	736	if (!isnil(arg)) { printf(" "); }
	737	}
	738	printf("\n");
	739	break;
	740
	741	case P_LT: numcmpop(<); break;
	742	case P_LTE: numcmpop(<=); break;
	743	case P_ADD: arithop(+); break;
	744	case P_SUB: arithop(-); break;
	745	case P_MUL: arithop(*); break;
	746	case P_DIV: arithop(/); break;
	747	}
	748	break;
	749
	750	case FE_TCFUNC:
	751	res = cfunc(fn)(ctx, evallist(ctx, arg, env));
	752	break;
	753
	754	case FE_TFUNC:
	755	arg = evallist(ctx, arg, env);
	756	va = cdr(fn); /* (env params ...) */
	757	vb = cdr(va); /* (params ...) */
	758	res = dolist(ctx, cdr(vb), argstoenv(ctx, car(vb), arg, car(va)));
	759	break;
	760
	761	case FE_TMACRO:
	762	va = cdr(fn); /* (env params ...) */
	763	vb = cdr(va); /* (params ...) */
	764	/* replace caller object with code generated by macro and re-eval */
	765	obj = dolist(ctx, cdr(vb), argstoenv(ctx, car(vb), arg, car(va)));
	766	fe_restoregc(ctx, gc);
	767	ctx->calllist = cdr(&cl);
	768	return eval(ctx, obj, env, NULL);
	769
	770	default:
	771	fe_error(ctx, "tried to call non-callable value");
	772	}
	773
	774	fe_restoregc(ctx, gc);
	775	fe_pushgc(ctx, res);
	776	ctx->calllist = cdr(&cl);
	777	return res;
	778	}
	779
	780
	781	fe_Object* fe_eval(fe_Context ctx, fe_Object obj) {
	782	return eval(ctx, obj, &nil, NULL);
	783	}
	784
	785
	786	fe_Context* fe_open(void *ptr, int size) {
	787	int i, save;
	788	fe_Context *ctx;
	789
	790	/* init context struct */
	791	ctx = ptr;
	792	memset(ctx, 0, sizeof(fe_Context));
	793	ptr = (char*) ptr + sizeof(fe_Context);
	794	size -= sizeof(fe_Context);
	795
	796	/* make sure object memory region is 32bit aligned */
	797	while ((size_t) ptr & 0x3) { ptr = (char*) ptr + 1; size--; }
	798
	799	/* init objects memory region */
	800	ctx->objects = (fe_Object*) ptr;
	801	ctx->object_count = size / sizeof(fe_Object);
	802
	803	/* init lists */
	804	ctx->calllist = &nil;
	805	ctx->freelist = &nil;
	806	ctx->symlist = &nil;
	807
	808	/* populate freelist */
	809	for (i = 0; i < ctx->object_count; i++) {
	810	fe_Object *obj = &ctx->objects[i];
	811	settype(obj, FE_TFREE);
	812	cdr(obj) = ctx->freelist;
	813	ctx->freelist = obj;
	814	}
	815
	816	/* init objects */
	817	ctx->t = fe_symbol(ctx, "t");
	818	fe_set(ctx, ctx->t, ctx->t);
	819
	820	/* register built in primitives */
	821	save = fe_savegc(ctx);
	822	for (i = 0; i < P_MAX; i++) {
	823	fe_Object *v = object(ctx);
	824	settype(v, FE_TPRIM);
	825	prim(v) = i;
	826	fe_set(ctx, fe_symbol(ctx, primnames[i]), v);
	827	fe_restoregc(ctx, save);
	828	}
	829
	830	return ctx;
	831	}
	832
	833
	834	void fe_close(fe_Context *ctx) {
	835	/* clear gcstack and symlist; makes all objects unreachable */
	836	ctx->gcstack_idx = 0;
	837	ctx->symlist = &nil;
	838	collectgarbage(ctx);
	839	}
	840
	841
	842	#ifdef FE_STANDALONE
	843
	844	#include <setjmp.h>
	845
	846	static jmp_buf toplevel;
	847	static char buf[64000];
	848
	849	static void onerror(fe_Context ctx, const char msg, fe_Object *cl) {
	850	unused(ctx), unused(cl);
	851	fprintf(stderr, "error: %s\n", msg);
	852	longjmp(toplevel, -1);
	853	}
	854
	855
	856	int main(int argc, char **argv) {
	857	int gc;
	858	fe_Object *obj;
	859	FILE *volatile fp = stdin;
	860	fe_Context *ctx = fe_open(buf, sizeof(buf));
	861
	862	/* init input file */
	863	if (argc > 1) {
	864	fp = fopen(argv[1], "rb");
	865	if (!fp) { fe_error(ctx, "could not open input file"); }
	866	}
	867
	868	if (fp == stdin) { fe_handlers(ctx)->error = onerror; }
	869	gc = fe_savegc(ctx);
	870	setjmp(toplevel);
	871
	872	/* re(p)l */
	873	for (;;) {
	874	fe_restoregc(ctx, gc);
	875	if (fp == stdin) { printf("> "); }
	876	if (!(obj = fe_readfp(ctx, fp))) { break; }
	877	obj = fe_eval(ctx, obj);
	878	if (fp == stdin) { fe_writefp(ctx, obj, stdout); printf("\n"); }
	879	}
	880
	881	return EXIT_SUCCESS;
	882	}
	883
	884	#endif

fe.h+61−0

@@ -0,0 +1,61 @@
	1	/*
	2	** Copyright (c) 2019 rxi
	3	**
	4	** This library is free software; you can redistribute it and/or modify it
	5	** under the terms of the MIT license. See `fe.c` for details.
	6	*/
	7
	8	#ifndef FE_H
	9	#define FE_H
	10
	11	#include <stdlib.h>
	12	#include <stdio.h>
	13
	14	#define FE_VERSION "1.0"
	15
	16	typedef float fe_Number;
	17	typedef struct fe_Object fe_Object;
	18	typedef struct fe_Context fe_Context;
	19	typedef fe_Object* (fe_CFunc)(fe_Context ctx, fe_Object *args);
	20	typedef void (fe_ErrorFn)(fe_Context ctx, const char err, fe_Object cl);
	21	typedef void (fe_WriteFn)(fe_Context ctx, void *udata, char chr);
	22	typedef char (fe_ReadFn)(fe_Context ctx, void *udata);
	23	typedef struct { fe_ErrorFn error; fe_CFunc mark, gc; } fe_Handlers;
	24
	25	enum {
	26	FE_TPAIR, FE_TFREE, FE_TNIL, FE_TNUMBER, FE_TSYMBOL, FE_TSTRING,
	27	FE_TFUNC, FE_TMACRO, FE_TPRIM, FE_TCFUNC, FE_TPTR
	28	};
	29
	30	fe_Context* fe_open(void *ptr, int size);
	31	void fe_close(fe_Context *ctx);
	32	fe_Handlers* fe_handlers(fe_Context *ctx);
	33	void fe_error(fe_Context ctx, const char msg);
	34	fe_Object* fe_nextarg(fe_Context ctx, fe_Object *arg);
	35	int fe_type(fe_Context ctx, fe_Object obj);
	36	int fe_isnil(fe_Context ctx, fe_Object obj);
	37	void fe_pushgc(fe_Context ctx, fe_Object obj);
	38	void fe_restoregc(fe_Context *ctx, int idx);
	39	int fe_savegc(fe_Context *ctx);
	40	void fe_mark(fe_Context ctx, fe_Object obj);
	41	fe_Object* fe_cons(fe_Context ctx, fe_Object car, fe_Object *cdr);
	42	fe_Object* fe_bool(fe_Context *ctx, int b);
	43	fe_Object* fe_number(fe_Context *ctx, fe_Number n);
	44	fe_Object* fe_string(fe_Context ctx, const char str);
	45	fe_Object* fe_symbol(fe_Context ctx, const char name);
	46	fe_Object* fe_cfunc(fe_Context *ctx, fe_CFunc fn);
	47	fe_Object* fe_ptr(fe_Context ctx, void ptr);
	48	fe_Object* fe_list(fe_Context ctx, fe_Object *objs, int n);
	49	fe_Object* fe_car(fe_Context ctx, fe_Object obj);
	50	fe_Object* fe_cdr(fe_Context ctx, fe_Object obj);
	51	void fe_write(fe_Context ctx, fe_Object obj, fe_WriteFn fn, void *udata, int qt);
	52	void fe_writefp(fe_Context ctx, fe_Object obj, FILE *fp);
	53	int fe_tostring(fe_Context ctx, fe_Object obj, char *dst, int size);
	54	fe_Number fe_tonumber(fe_Context ctx, fe_Object obj);
	55	void* fe_toptr(fe_Context ctx, fe_Object obj);
	56	void fe_set(fe_Context ctx, fe_Object sym, fe_Object *v);
	57	fe_Object* fe_read(fe_Context ctx, fe_ReadFn fn, void udata);
	58	fe_Object* fe_readfp(fe_Context ctx, FILE fp);
	59	fe_Object* fe_eval(fe_Context ctx, fe_Object obj);
	60
	61	#endif

scripts/fib.fe+10−0

@@ -0,0 +1,10 @@
	1
	2	(= fib (fn (n)
	3	(if (<= 2 n)
	4	(+ (fib (- n 1)) (fib (- n 2)))
	5	n
	6	)
	7	))
	8
	9	(print (fib 28))
	10

scripts/life.fe+112−0

@@ -0,0 +1,112 @@
	1	(= nth (fn (n lst)
	2	(while (< 0 n)
	3	(= n (- n 1))
	4	(= lst (cdr lst)))
	5	(if (is n 0) (car lst))
	6	))
	7
	8
	9	(= rev (fn (lst)
	10	(let res nil)
	11	(while lst
	12	(= res (cons (car lst) res))
	13	(= lst (cdr lst))
	14	)
	15	res
	16	))
	17
	18
	19	(= map (fn (f lst)
	20	(let res nil)
	21	(while lst
	22	(= res (cons (f (car lst)) res))
	23	(= lst (cdr lst))
	24	)
	25	(rev res)
	26	))
	27
	28
	29	(= print-grid (fn (grid)
	30	(map
	31	(fn (row)
	32	(print (map (fn (x) (if (is x 0) '- '#)) row))
	33	)
	34	grid
	35	)
	36	))
	37
	38
	39	(= get-cell (fn (grid x y)
	40	(or (nth x (nth y grid)) 0)
	41	))
	42
	43
	44	(= next-cell (fn (grid cell x y)
	45	(let n (+
	46	(get-cell grid (- x 1) (- y 1))
	47	(get-cell grid (- x 1) y )
	48	(get-cell grid (- x 1) (+ y 1))
	49	(get-cell grid x (- y 1))
	50	(get-cell grid x (+ y 1))
	51	(get-cell grid (+ x 1) (- y 1))
	52	(get-cell grid (+ x 1) y )
	53	(get-cell grid (+ x 1) (+ y 1))
	54	))
	55	(if
	56	(and (is cell 1) (or (is n 2) (is n 3))) 1
	57	(and (is cell 0) (is n 3)) 1
	58	0
	59	)
	60	))
	61
	62
	63	(= next-grid (fn (grid)
	64	(let y -1)
	65	(map
	66	(fn (row)
	67	(= y (+ y 1))
	68	(let x -1)
	69	(map
	70	(fn (cell)
	71	(= x (+ x 1))
	72	(next-cell grid cell x y)
	73	)
	74	row
	75	)
	76	)
	77	grid
	78	)
	79	))
	80
	81
	82	(= life (fn (n grid)
	83	(let i 1)
	84	(while (<= i n)
	85	(print ">> iteration" i)
	86	(print-grid grid)
	87	(print)
	88	(= grid (next-grid grid))
	89	(= i (+ i 1))
	90	)
	91	))
	92
	93
	94	; blinker in a 3x3 universe
	95	(life 5 '(
	96	(0 1 0)
	97	(0 1 0)
	98	(0 1 0)
	99	))
	100
	101
	102	; glider in an 8x8 universe
	103	(life 22 '(
	104	(0 0 1 0 0 0 0 0)
	105	(0 0 0 1 0 0 0 0)
	106	(0 1 1 1 0 0 0 0)
	107	(0 0 0 0 0 0 0 0)
	108	(0 0 0 0 0 0 0 0)
	109	(0 0 0 0 0 0 0 0)
	110	(0 0 0 0 0 0 0 0)
	111	(0 0 0 0 0 0 0 0)
	112	))

scripts/mandelbrot.fe+35−0

@@ -0,0 +1,35 @@
	1	; printed output should be written to a .pgm file
	2
	3	(do
	4	(let width 500)
	5	(let height 300)
	6	(let maxiter 16)
	7
	8	; write header
	9	(print "P2")
	10	(print width height)
	11	(print maxiter)
	12
	13	; write pixels
	14	(let ypixel 0)
	15	(while (< ypixel height)
	16	(let y (- (/ ypixel (/ height 2)) 1))
	17	(let xpixel 0)
	18	(while (< xpixel width)
	19	(let x (- (/ xpixel (/ width 3)) 2))
	20	(let x0 x)
	21	(let y0 y)
	22	(let iter 0)
	23	(while (and (< iter maxiter) (<= (+ (* x0 x0) (* y0 y0)) 4))
	24	(let x1 (+ (- (* x0 x0) (* y0 y0)) x))
	25	(let y1 (+ (* 2 x0 y0) y))
	26	(= x0 x1)
	27	(= y0 y1)
	28	(= iter (+ iter 1))
	29	)
	30	(print iter)
	31	(= xpixel (+ xpixel 1))
	32	)
	33	(= ypixel (+ ypixel 1))
	34	)
	35	)

Initial commit

Keyboard shortcuts

General

Issues and pull requests

Issues, pull requests and Inbox

Repository code