History

Initial commit

rxi committed 7 years ago

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

Unified · Split

9 files
  1. LICENSE +19 −0
  2. README.md +42 −0
  3. doc/impl.md +155 −0
  4. doc/lang.md +143 −0
  5. fe.c +884 −0
  6. fe.h +61 −0
  7. scripts/fib.fe +10 −0
  8. scripts/life.fe +112 −0
  9. scripts/mandelbrot.fe +35 −0
LICENSE+19−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+)

Keyboard shortcuts

General

Show keyboard shortcuts
?
Focus the current search
/

Issues and pull requests

Open filters
f

Issues, pull requests and Inbox

Select next item
j↓
Select previous item
k↑
Open selected item
Enter
Dismiss filters or clear selection
Esc

Repository code

Go to file
t