├── LICENSE ├── README.md ├── build.bat ├── build.sh ├── doc ├── capi.md ├── impl.md └── lang.md ├── scripts ├── fib.fe ├── life.fe ├── macros.fe └── mandelbrot.fe └── src ├── fe.c └── fe.h /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020 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. 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 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 | * **[C API Overview](doc/capi.md)** 32 | * **[Language Overview](doc/lang.md)** 33 | * **[Implementation Overview](doc/impl.md)** 34 | 35 | 36 | ## Contributing 37 | The library focuses on being lightweight and minimal; pull requests will 38 | likely not be merged. Bug reports and questions are welcome. 39 | 40 | 41 | ## License 42 | This library is free software; you can redistribute it and/or modify it under 43 | the terms of the MIT license. See [LICENSE](LICENSE) for details. 44 | -------------------------------------------------------------------------------- /build.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | 3 | rem download this: 4 | rem https://nuwen.net/mingw.html 5 | 6 | gcc src/fe.c -DFE_STANDALONE -O3 -o fe -Wall -Wextra -std=c89 -pedantic 7 | strip fe.exe 8 | -------------------------------------------------------------------------------- /build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | gcc src/fe.c -DFE_STANDALONE -O3 -o fe -Wall -Wextra -std=c89 -pedantic 3 | -------------------------------------------------------------------------------- /doc/capi.md: -------------------------------------------------------------------------------- 1 | 2 | # C API 3 | To use `fe` in a project a `fe_Context` must first be initialized; 4 | this is done by using the `fe_open()` function. The function expects a 5 | block of memory (typically greater than 16kb), the block is used by the 6 | context to store objects and context state and should remain valid for 7 | the lifetime of the context. `fe_close()` should be called when you are 8 | finished with a context, this will assure any `ptr` objects are properly 9 | garbage collected. 10 | 11 | ```c 12 | int size = 1024 * 1024; 13 | void *data = malloc(size); 14 | 15 | fe_Context *ctx = fe_open(data, size); 16 | 17 | /* ... */ 18 | 19 | fe_close(ctx); 20 | free(data); 21 | ``` 22 | 23 | 24 | ## Running a script 25 | To run a script it should first be read then evaluated; this should be 26 | done in a loop if there are several root-level expressions contained in 27 | the script. `fe_readfp()` is provided as a convenience to read from a 28 | file pointer; `fe_read()` can be used with a custom `fe_ReadFn` callback 29 | function to read from other sources. 30 | 31 | ```c 32 | FILE *fp = fopen("test.fe", "rb"); 33 | int gc = fe_savegc(ctx); 34 | 35 | for (;;) { 36 | fe_Object *obj = fe_readfp(ctx, fp); 37 | 38 | /* break if there's nothing left to read */ 39 | if (!obj) { break; } 40 | 41 | /* evaluate read object */ 42 | fe_eval(ctx, obj); 43 | 44 | /* restore GC stack which would now contain both the read object and 45 | ** result from evaluation */ 46 | fe_restoregc(ctx, gc); 47 | } 48 | 49 | fclose(fp); 50 | ``` 51 | 52 | 53 | ## Calling a function 54 | A function can be called by creating a list and evaulating it; for 55 | example, we could add two numbers using the `+` function: 56 | 57 | ```c 58 | int gc = fe_savegc(ctx); 59 | 60 | fe_Object *objs[3]; 61 | objs[0] = fe_symbol(ctx, "+"); 62 | objs[1] = fe_number(ctx, 10); 63 | objs[2] = fe_number(ctx, 20); 64 | 65 | fe_Object *res = fe_eval(ctx, fe_list(ctx, objs, 3)); 66 | printf("result: %g\n", fe_tonumber(ctx, res)); 67 | 68 | /* discard all temporary objects pushed to the GC stack */ 69 | fe_restoregc(ctx, gc); 70 | ``` 71 | 72 | 73 | ## Creating a cfunc 74 | A `cfunc` can be created by using the `fe_cfunc()` function with a 75 | `fe_CFunc` function argument. The `cfunc` can be bound to a global 76 | variable by using the `fe_set()` function. `cfunc`s take a context and 77 | argument list as its arguments and returns a result object. The result 78 | should never be `NULL`; in the case of wanting to return `nil` the value 79 | returned by `fe_bool(ctx, 0)` should be used. 80 | 81 | The `pow` function from `math.h` could be wrapped as such: 82 | 83 | ```c 84 | static fe_Object* f_pow(fe_Context *ctx, fe_Object *arg) { 85 | float x = fe_tonumber(ctx, fe_nextarg(ctx, &arg)); 86 | float y = fe_tonumber(ctx, fe_nextarg(ctx, &arg)); 87 | return fe_number(ctx, pow(x, y)); 88 | } 89 | 90 | fe_set(ctx, fe_symbol(ctx, "pow"), fe_cfunc(ctx, f_pow)); 91 | ``` 92 | 93 | The `cfunc` could then be called like any other function: 94 | 95 | ```clojure 96 | (print (pow 2 10)) 97 | ``` 98 | 99 | 100 | ## Creating a ptr 101 | The `ptr` object type is provided to allow for custom objects. By default 102 | no type checking is performed and thus pointers must be wrapped by the 103 | user and tagged to assure type safety if more than one type of pointer 104 | is used. 105 | 106 | A `ptr` object can be created by using the `fe_ptr()` function. 107 | 108 | The `gc` and `mark` handlers are provided for dealing with `ptr`s 109 | regarding garbage collection. Whenever a `ptr` is marked by the GC the 110 | `mark` handler is called on it — this is useful if the `ptr` stores 111 | additional objects which also need to be marked via `fe_mark()`. The 112 | `gc` handler is called on the `ptr` when it becomes unreachable and is 113 | garbage collected, such that the resources used by the `ptr` can be 114 | freed. The handlers can be set by setting the relevant fields in the 115 | struct returned by `fe_handlers()`. 116 | 117 | 118 | ## Error handling 119 | When an error occurs the `fe_error()` is called; by default, the 120 | error and stack traceback is printed and the program exited. If you want 121 | to recover from an error the `error` handler field in the struct returned 122 | by `fe_handlers()` can be set and `longjmp()` can be used to exit the 123 | handler; the context is left in a safe state and can continue to be 124 | used. New `fe_Object`s should not be created inside the error handler. 125 | -------------------------------------------------------------------------------- /doc/impl.md: -------------------------------------------------------------------------------- 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, `fe_read()` and `fe_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 `fe_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 `fe_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 156 | -------------------------------------------------------------------------------- /doc/lang.md: -------------------------------------------------------------------------------- 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. 144 | -------------------------------------------------------------------------------- /scripts/fib.fe: -------------------------------------------------------------------------------- 1 | (= fib (fn (n) 2 | (if (<= 2 n) 3 | (+ (fib (- n 1)) (fib (- n 2))) 4 | n 5 | ) 6 | )) 7 | 8 | (print (fib 28)) 9 | -------------------------------------------------------------------------------- /scripts/life.fe: -------------------------------------------------------------------------------- 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 | )) 113 | -------------------------------------------------------------------------------- /scripts/macros.fe: -------------------------------------------------------------------------------- 1 | (= push (mac (val lst) 2 | (list '= lst (list 'cons val lst)) 3 | )) 4 | 5 | 6 | (= for (mac (item lst . body) 7 | (list 'do 8 | (list 'let 'for-iter lst) 9 | (list 'while 'for-iter 10 | (list 'let item '(car for-iter)) 11 | '(= for-iter (cdr for-iter)) 12 | (cons 'do body) 13 | ) 14 | ) 15 | )) 16 | 17 | 18 | (= items (list "cat" "dog" "fox")) 19 | 20 | (push "owl" items) 21 | (push "cow" items) 22 | 23 | (for x items 24 | (print ">" x) 25 | ) 26 | -------------------------------------------------------------------------------- /scripts/mandelbrot.fe: -------------------------------------------------------------------------------- 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 | ) 36 | -------------------------------------------------------------------------------- /src/fe.c: -------------------------------------------------------------------------------- 1 | /* 2 | ** Copyright (c) 2020 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 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); a = cdr(a), b = cdr(b)) { 206 | if (car(a) != car(b)) { return 0; } 207 | } 208 | return a == 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, lst); 577 | fe_pushgc(ctx, env); 578 | res = eval(ctx, fe_nextarg(ctx, &lst), env, &env); 579 | } 580 | return res; 581 | } 582 | 583 | 584 | static fe_Object* argstoenv(fe_Context *ctx, fe_Object *prm, fe_Object *arg, fe_Object *env) { 585 | while (!isnil(prm)) { 586 | if (type(prm) != FE_TPAIR) { 587 | env = fe_cons(ctx, fe_cons(ctx, prm, arg), env); 588 | break; 589 | } 590 | env = fe_cons(ctx, fe_cons(ctx, car(prm), fe_car(ctx, arg)), env); 591 | prm = cdr(prm); 592 | arg = fe_cdr(ctx, arg); 593 | } 594 | return env; 595 | } 596 | 597 | 598 | #define evalarg() eval(ctx, fe_nextarg(ctx, &arg), env, NULL) 599 | 600 | #define arithop(op) { \ 601 | fe_Number x = fe_tonumber(ctx, evalarg()); \ 602 | while (!isnil(arg)) { \ 603 | x = x op fe_tonumber(ctx, evalarg()); \ 604 | } \ 605 | res = fe_number(ctx, x); \ 606 | } 607 | 608 | #define numcmpop(op) { \ 609 | va = checktype(ctx, evalarg(), FE_TNUMBER); \ 610 | vb = checktype(ctx, evalarg(), FE_TNUMBER); \ 611 | res = fe_bool(ctx, number(va) op number(vb)); \ 612 | } 613 | 614 | 615 | static fe_Object* eval(fe_Context *ctx, fe_Object *obj, fe_Object *env, fe_Object **newenv) { 616 | fe_Object *fn, *arg, *res; 617 | fe_Object cl, *va, *vb; 618 | int n, gc; 619 | 620 | if (type(obj) == FE_TSYMBOL) { return cdr(getbound(obj, env)); } 621 | if (type(obj) != FE_TPAIR) { return obj; } 622 | 623 | car(&cl) = obj, cdr(&cl) = ctx->calllist; 624 | ctx->calllist = &cl; 625 | 626 | gc = fe_savegc(ctx); 627 | fn = eval(ctx, car(obj), env, NULL); 628 | arg = cdr(obj); 629 | res = &nil; 630 | 631 | switch (type(fn)) { 632 | case FE_TPRIM: 633 | switch (prim(fn)) { 634 | case P_LET: 635 | va = checktype(ctx, fe_nextarg(ctx, &arg), FE_TSYMBOL); 636 | if (newenv) { 637 | *newenv = fe_cons(ctx, fe_cons(ctx, va, evalarg()), env); 638 | } 639 | break; 640 | 641 | case P_SET: 642 | va = checktype(ctx, fe_nextarg(ctx, &arg), FE_TSYMBOL); 643 | cdr(getbound(va, env)) = evalarg(); 644 | break; 645 | 646 | case P_IF: 647 | while (!isnil(arg)) { 648 | va = evalarg(); 649 | if (!isnil(va)) { 650 | res = isnil(arg) ? va : evalarg(); 651 | break; 652 | } 653 | if (isnil(arg)) { break; } 654 | arg = cdr(arg); 655 | } 656 | break; 657 | 658 | case P_FN: case P_MAC: 659 | va = fe_cons(ctx, env, arg); 660 | fe_nextarg(ctx, &arg); 661 | res = object(ctx); 662 | settype(res, prim(fn) == P_FN ? FE_TFUNC : FE_TMACRO); 663 | cdr(res) = va; 664 | break; 665 | 666 | case P_WHILE: 667 | va = fe_nextarg(ctx, &arg); 668 | n = fe_savegc(ctx); 669 | while (!isnil(eval(ctx, va, env, NULL))) { 670 | dolist(ctx, arg, env); 671 | fe_restoregc(ctx, n); 672 | } 673 | break; 674 | 675 | case P_QUOTE: 676 | res = fe_nextarg(ctx, &arg); 677 | break; 678 | 679 | case P_AND: 680 | while (!isnil(arg) && !isnil(res = evalarg())); 681 | break; 682 | 683 | case P_OR: 684 | while (!isnil(arg) && isnil(res = evalarg())); 685 | break; 686 | 687 | case P_DO: 688 | res = dolist(ctx, arg, env); 689 | break; 690 | 691 | case P_CONS: 692 | va = evalarg(); 693 | res = fe_cons(ctx, va, evalarg()); 694 | break; 695 | 696 | case P_CAR: 697 | res = fe_car(ctx, evalarg()); 698 | break; 699 | 700 | case P_CDR: 701 | res = fe_cdr(ctx, evalarg()); 702 | break; 703 | 704 | case P_SETCAR: 705 | va = checktype(ctx, evalarg(), FE_TPAIR); 706 | car(va) = evalarg(); 707 | break; 708 | 709 | case P_SETCDR: 710 | va = checktype(ctx, evalarg(), FE_TPAIR); 711 | cdr(va) = evalarg(); 712 | break; 713 | 714 | case P_LIST: 715 | res = evallist(ctx, arg, env); 716 | break; 717 | 718 | case P_NOT: 719 | res = fe_bool(ctx, isnil(evalarg())); 720 | break; 721 | 722 | case P_IS: 723 | va = evalarg(); 724 | res = fe_bool(ctx, equal(va, evalarg())); 725 | break; 726 | 727 | case P_ATOM: 728 | res = fe_bool(ctx, fe_type(ctx, evalarg()) != FE_TPAIR); 729 | break; 730 | 731 | case P_PRINT: 732 | while (!isnil(arg)) { 733 | fe_writefp(ctx, evalarg(), stdout); 734 | if (!isnil(arg)) { printf(" "); } 735 | } 736 | printf("\n"); 737 | break; 738 | 739 | case P_LT: numcmpop(<); break; 740 | case P_LTE: numcmpop(<=); break; 741 | case P_ADD: arithop(+); break; 742 | case P_SUB: arithop(-); break; 743 | case P_MUL: arithop(*); break; 744 | case P_DIV: arithop(/); break; 745 | } 746 | break; 747 | 748 | case FE_TCFUNC: 749 | res = cfunc(fn)(ctx, evallist(ctx, arg, env)); 750 | break; 751 | 752 | case FE_TFUNC: 753 | arg = evallist(ctx, arg, env); 754 | va = cdr(fn); /* (env params ...) */ 755 | vb = cdr(va); /* (params ...) */ 756 | res = dolist(ctx, cdr(vb), argstoenv(ctx, car(vb), arg, car(va))); 757 | break; 758 | 759 | case FE_TMACRO: 760 | va = cdr(fn); /* (env params ...) */ 761 | vb = cdr(va); /* (params ...) */ 762 | /* replace caller object with code generated by macro and re-eval */ 763 | *obj = *dolist(ctx, cdr(vb), argstoenv(ctx, car(vb), arg, car(va))); 764 | fe_restoregc(ctx, gc); 765 | ctx->calllist = cdr(&cl); 766 | return eval(ctx, obj, env, NULL); 767 | 768 | default: 769 | fe_error(ctx, "tried to call non-callable value"); 770 | } 771 | 772 | fe_restoregc(ctx, gc); 773 | fe_pushgc(ctx, res); 774 | ctx->calllist = cdr(&cl); 775 | return res; 776 | } 777 | 778 | 779 | fe_Object* fe_eval(fe_Context *ctx, fe_Object *obj) { 780 | return eval(ctx, obj, &nil, NULL); 781 | } 782 | 783 | 784 | fe_Context* fe_open(void *ptr, int size) { 785 | int i, save; 786 | fe_Context *ctx; 787 | 788 | /* init context struct */ 789 | ctx = ptr; 790 | memset(ctx, 0, sizeof(fe_Context)); 791 | ptr = (char*) ptr + sizeof(fe_Context); 792 | size -= sizeof(fe_Context); 793 | 794 | /* init objects memory region */ 795 | ctx->objects = (fe_Object*) ptr; 796 | ctx->object_count = size / sizeof(fe_Object); 797 | 798 | /* init lists */ 799 | ctx->calllist = &nil; 800 | ctx->freelist = &nil; 801 | ctx->symlist = &nil; 802 | 803 | /* populate freelist */ 804 | for (i = 0; i < ctx->object_count; i++) { 805 | fe_Object *obj = &ctx->objects[i]; 806 | settype(obj, FE_TFREE); 807 | cdr(obj) = ctx->freelist; 808 | ctx->freelist = obj; 809 | } 810 | 811 | /* init objects */ 812 | ctx->t = fe_symbol(ctx, "t"); 813 | fe_set(ctx, ctx->t, ctx->t); 814 | 815 | /* register built in primitives */ 816 | save = fe_savegc(ctx); 817 | for (i = 0; i < P_MAX; i++) { 818 | fe_Object *v = object(ctx); 819 | settype(v, FE_TPRIM); 820 | prim(v) = i; 821 | fe_set(ctx, fe_symbol(ctx, primnames[i]), v); 822 | fe_restoregc(ctx, save); 823 | } 824 | 825 | return ctx; 826 | } 827 | 828 | 829 | void fe_close(fe_Context *ctx) { 830 | /* clear gcstack and symlist; makes all objects unreachable */ 831 | ctx->gcstack_idx = 0; 832 | ctx->symlist = &nil; 833 | collectgarbage(ctx); 834 | } 835 | 836 | 837 | #ifdef FE_STANDALONE 838 | 839 | #include 840 | 841 | static jmp_buf toplevel; 842 | static char buf[64000]; 843 | 844 | static void onerror(fe_Context *ctx, const char *msg, fe_Object *cl) { 845 | unused(ctx), unused(cl); 846 | fprintf(stderr, "error: %s\n", msg); 847 | longjmp(toplevel, -1); 848 | } 849 | 850 | 851 | int main(int argc, char **argv) { 852 | int gc; 853 | fe_Object *obj; 854 | FILE *volatile fp = stdin; 855 | fe_Context *ctx = fe_open(buf, sizeof(buf)); 856 | 857 | /* init input file */ 858 | if (argc > 1) { 859 | fp = fopen(argv[1], "rb"); 860 | if (!fp) { fe_error(ctx, "could not open input file"); } 861 | } 862 | 863 | if (fp == stdin) { fe_handlers(ctx)->error = onerror; } 864 | gc = fe_savegc(ctx); 865 | setjmp(toplevel); 866 | 867 | /* re(p)l */ 868 | for (;;) { 869 | fe_restoregc(ctx, gc); 870 | if (fp == stdin) { printf("> "); } 871 | if (!(obj = fe_readfp(ctx, fp))) { break; } 872 | obj = fe_eval(ctx, obj); 873 | if (fp == stdin) { fe_writefp(ctx, obj, stdout); printf("\n"); } 874 | } 875 | 876 | return EXIT_SUCCESS; 877 | } 878 | 879 | #endif 880 | -------------------------------------------------------------------------------- /src/fe.h: -------------------------------------------------------------------------------- 1 | /* 2 | ** Copyright (c) 2020 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 12 | #include 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 62 | --------------------------------------------------------------------------------