Commit d9b2b2f2 authored by Juergen Nickelsen's avatar Juergen Nickelsen
Browse files

Slight simplification of the basic object handling; begun to write

comments for the builtins.
parent 76a2088a
......@@ -12,7 +12,7 @@
* format (seems not as difficult as it did)
* destructuring let(?)
(* destructuring let)
@ garbage collection
......
......@@ -12,10 +12,22 @@
#include "gc.h"
/*
* All builtin functions are called by call_builtin(). They have the number of
* arguments checked beforehand, so they can rely on the actual number of
* arguments being in the range specified with register_builtin(). The args list
* is the one created by evalfun() and is gc-protected. The out_port argument is
* the port to print errors to etc.; it will be replaced by a more generalized
* interpreter context (or rather repl context) finally.
*/
obp_t new_autoload_function(char *name, uint namelen_t, obp_t filename,
int is_special);
/**
* Return the length of the list, i. e. the number of pairs.
*/
uint list_length(obp_t list)
{
uint length = 0;
......@@ -26,6 +38,11 @@ uint list_length(obp_t list)
return length;
}
/**
* Call a builtin function and return the value (or error). The function object
* fun must be of type F_BUILTIN. Check the number of arguments against the
* range specified with register_builtin().
*/
obp_t call_builtin(obp_t fun, obp_t args, obp_t out_port, int level)
{
Lfunction_t *bi = AS(fun, FUNCTION);
......@@ -41,6 +58,11 @@ obp_t call_builtin(obp_t fun, obp_t args, obp_t out_port, int level)
return bi->impl.builtin(nargs, args, out_port, level);
}
/**
* Return the length of the argument. Supported are lists, strings, vectors,
* maps (number of entries), strbufs, symbols (length of name).
* (length arg)
*/
obp_t bf_length(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t ob = CAR(args);
......@@ -72,6 +94,9 @@ obp_t bf_length(int nargs, obp_t args, obp_t out_port, int level)
return new_integer(value);
}
/**
* (setq sym1 val1 ... ...)
*/
obp_t bf_setq(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
......@@ -100,6 +125,9 @@ obp_t bf_setq(int nargs, obp_t args, obp_t out_port, int level)
return retval;
}
/**
* Return a function object. (lambda args [bodyform ...])
*/
obp_t bf_lambda(int nargs, obp_t args, obp_t out_port, int level)
{
return make_function(0, 0, new_pair(the_Lambda, args), out_port);
......@@ -135,6 +163,10 @@ obp_t bf_if(int nargs, obp_t args, obp_t out_port, int level)
return retval;
}
/**
* Return the car of a pair or, of nil, nil.
* (car arg)
*/
obp_t bf_car(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t arg = CAR(args);
......@@ -147,6 +179,10 @@ obp_t bf_car(int nargs, obp_t args, obp_t out_port, int level)
}
}
/**
* Return the cdr of a pair or, of nil, nil.
* (cdr arg)
*/
obp_t bf_cdr(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t arg = CAR(args);
......@@ -159,6 +195,9 @@ obp_t bf_cdr(int nargs, obp_t args, obp_t out_port, int level)
}
}
/**
* (cons carval cdrval)
*/
obp_t bf_cons(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t arg1 = CAR(args);
......@@ -166,16 +205,29 @@ obp_t bf_cons(int nargs, obp_t args, obp_t out_port, int level)
return new_pair(arg1, arg2);
}
/**
* Evaluate an object and return the value.
* (eval obj)
*/
obp_t bf_eval(int nargs, obp_t args, obp_t out_port, int level)
{
return eval(CAR(args), out_port, level);
}
/**
* Return the literal argument.
* (quote arg)
*/
obp_t bf_quote(int nargs, obp_t args, obp_t out_port, int level)
{
return CAR(args);
}
/**
* Load a file and evaluate its contents. The filename may be a string or a
* symbol.
* (load filename)
*/
obp_t bf_load(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
......@@ -197,6 +249,10 @@ obp_t bf_load(int nargs, obp_t args, obp_t out_port, int level)
return retval;;
}
/**
* Return the name of a symbol as a string.
* (symbol-name sym)
*/
obp_t bf_symbol_name(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t sym = CAR(args);
......@@ -204,6 +260,10 @@ obp_t bf_symbol_name(int nargs, obp_t args, obp_t out_port, int level)
return AS(sym, SYMBOL)->name;
}
/**
* Return the function associated with a symbol.
* (symbol-function sym)
*/
obp_t bf_symbol_function(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t sym = CAR(args);
......@@ -211,11 +271,19 @@ obp_t bf_symbol_function(int nargs, obp_t args, obp_t out_port, int level)
return AS(sym, SYMBOL)->function;
}
/**
* Return the list of all interned symbols.
* (symbols)
*/
obp_t bf_symbols(int nargs, obp_t args, obp_t out_port, int level)
{
return all_symbols();
}
/**
* Set the function associated with a symbol.
(fset sym function)
*/
obp_t bf_fset(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
......@@ -237,6 +305,9 @@ obp_t bf_fset(int nargs, obp_t args, obp_t out_port, int level)
return retval;
}
/**
* Common part of function and special form definitions.
*/
obp_t def_common(obp_t args, obp_t out_port, obp_t marker)
{
PROTECT;
......@@ -255,21 +326,38 @@ obp_t def_common(obp_t args, obp_t out_port, obp_t marker)
return retval;
}
/**
* Define a function.
* (defun name args [bodyform ...])
*/
obp_t bf_defun(int nargs, obp_t args, obp_t out_port, int level)
{
return def_common(args, out_port, the_Lambda);
}
/**
* Define a special form. Arguments are passed unevaluated.
* (defspecial name args [bodyform ...])
*/
obp_t bf_defspecial(int nargs, obp_t args, obp_t out_port, int level)
{
return def_common(args, out_port, the_Mu);
}
/**
* Return t if the two arguments are the same object, nil otherwise.
* (eq arg1 arg2)
*/
obp_t bf_eq(int nargs, obp_t args, obp_t out_port, int level)
{
return CAR(args) == CADR(args) ? the_T : the_Nil;
}
/**
* Return t if the two arguments are the same object or have the same (not
* equal!) value.
* (eql arg1 arg2)
*/
obp_t bf_eql(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t arg1 = CAR(args);
......@@ -287,6 +375,10 @@ obp_t bf_eql(int nargs, obp_t args, obp_t out_port, int level)
}
}
/**
* Return the sum of all arguments, which must be numbers.
* (+ [n1 ...])
*/
obp_t bf_plus(int nargs, obp_t args, obp_t out_port, int level)
{
long value = 0;
......@@ -299,6 +391,10 @@ obp_t bf_plus(int nargs, obp_t args, obp_t out_port, int level)
return new_integer(value);
}
/**
* Return the numeric value of the first argument minus all others.
* (- n1 [n2 ...])
*/
obp_t bf_minus(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t first = CAR(args);
......@@ -315,6 +411,10 @@ obp_t bf_minus(int nargs, obp_t args, obp_t out_port, int level)
return new_integer(value);
}
/**
* Return the product of all arguments, which must be numbers.
* (* [n1 ...])
*/
obp_t bf_times(int nargs, obp_t args, obp_t out_port, int level)
{
long value = 1;
......@@ -327,6 +427,10 @@ obp_t bf_times(int nargs, obp_t args, obp_t out_port, int level)
return new_integer(value);
}
/**
* Return the numeric value of the first argument divided by all others.
* (/ n1 [n2 ...])
*/
obp_t bf_divide(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t start = CAR(args);
......@@ -343,6 +447,10 @@ obp_t bf_divide(int nargs, obp_t args, obp_t out_port, int level)
return new_integer(value);
}
/**
* Return the numeric value of the first argument modulo all others.
* (% n1 [n2 ...])
*/
obp_t bf_modulo(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t start = CAR(args);
......@@ -359,6 +467,10 @@ obp_t bf_modulo(int nargs, obp_t args, obp_t out_port, int level)
return new_integer(value);
}
/**
* Return t if all arguments, which must be numbers, have the same value.
* (= n1 [n2 ...])
*/
obp_t bf_equals(int nargs, obp_t args, obp_t out_port, int level)
{
obp_t start = CAR(args);
......@@ -1015,6 +1127,25 @@ obp_t bf_trace_function(int nargs, obp_t args, obp_t out_port, int level)
}
obp_t bf_show_freelist(int nargs, obp_t args, obp_t out_port, int level)
{
PROTECT;
PROTVAR(retval);
PROTVAR(pair);
PROTVAR(size);
PROTVAR(count);
for (int i = FREELIST_ENTRIES - 1; i >= 0; i--) {
size = new_integer(i << 3);
count = new_integer(ob_sizecount[i]);
pair = cons(size, count);
retval = cons(pair, retval);
}
UNPROTECT;
return retval;
}
Lfunction_t *new_function_common(char *name, uint namelen, int is_special,
short minargs, short maxargs)
{
......@@ -1134,6 +1265,7 @@ void init_builtins(void)
register_builtin(APROPOS_NAME, bf_apropos, 0, 1, 1);
register_builtin(GC_NAME, bf_gc, 0, 0, 0);
register_builtin(TRACE_FUNCTION_NAME, bf_trace_function, 0, 1, 2);
register_builtin(SHOW_FREELIST_NAME, bf_show_freelist, 0, 0, 0);
gettimeofday(&start_time, 0);
}
......
......@@ -76,3 +76,4 @@
#define APROPOS_NAME "apropos"
#define GC_NAME "gc"
#define TRACE_FUNCTION_NAME "trace-function"
#define SHOW_FREELIST_NAME "show-freelist"
......@@ -14,12 +14,7 @@
* handled by malloc/free each time.
*/
#define OBSIZE_UNIT 8
#define FREELIST_ENTRIES 131 /* for strings up to 1K */
#define FREELIST_MAXSIZE ((FREELIST_ENTRIES - 1) * OBSIZE_UNIT)
obp_t freelist[FREELIST_ENTRIES];
long ob_sizecount[FREELIST_ENTRIES]; /* count objects per size */
......@@ -52,19 +47,18 @@ obp_t popup(void)
void ob_free(obp_t ob)
{
obp_t *size_freelist = freelist + (ob->size >> 3);
int index = ob->size >> 3;
memset(ob, 0, ob->size);
ob->next = *size_freelist;
*size_freelist = ob;
ob->next = freelist[index];
freelist[index] = ob;
ob_sizecount[index]++;
}
/**
* Create a new object and register it so it gets included in the garbage
* collection sweep (to be).
* collection sweep.
*/
obp_t new_object(uint size, int type)
{
......@@ -80,11 +74,13 @@ obp_t new_object(uint size, int type)
if (size % OBSIZE_UNIT) {
size += OBSIZE_UNIT - (size % OBSIZE_UNIT);
}
if (size <= FREELIST_MAXSIZE) {
obp_t *size_freelist = freelist + (size >> 3);
if (*size_freelist) {
ob = *size_freelist;
*size_freelist = (*size_freelist)->next;
int index = size >> 3;
if (freelist[index]) {
ob = freelist[index];
freelist[index] = freelist[index]->next;
ob_sizecount[index]--;
}
}
if (ob == 0) {
......@@ -93,6 +89,7 @@ obp_t new_object(uint size, int type)
object_count++;
memset(ob, 0, size);
assert(type);
ob->type = type;
ob->size = size;
ob->next = alloced_obs;
......
......@@ -255,7 +255,7 @@ void traverse_ob(obp_t ob, void (*do_func)(obp_t), int (*stop_func)(obp_t))
if (!ob || stop_func(ob)) {
return;
}
if (1 || traceflag) {
if (traceflag) {
printf(" %s: ", type_name(ob->type));
print(ob);
}
......
......@@ -14,6 +14,14 @@
#include "builtins.h"
#include "strbuf.h"
/*
* definitions for freelist management, see ob_common.c
*/
#define OBSIZE_UNIT 8
#define FREELIST_ENTRIES 131 /* for strings up to 1K */
#define FREELIST_MAXSIZE ((FREELIST_ENTRIES - 1) * OBSIZE_UNIT)
/* all types of objects */
typedef enum {
INVALiD = 0, /* to block uninitialized ones */
......@@ -309,6 +317,7 @@ extern obp_t alloced_obs; /* all objects not in a free list */
extern int traceflag;
extern long object_count;
extern long ob_sizecount[FREELIST_ENTRIES];
#endif /* __OBJECTS_H_INC */
......
#define GC_OBJ_COUNT 10 /* gc every n objects */
#define HMAP_MAXLISTLEN 4 /* Maximum length of bucket lists. */
/**
* For the moment the garbage collector is simply called after the allocation of
* so many objects.
*/
#define GC_OBJ_COUNT 10000
/**
* Maximum length of the bucket lists in the hashmap. The map will be expanded
* when this amount is exceeded.
*/
#define HMAP_MAXLISTLEN 4
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment