Commit 3d7d64c1 authored by Juergen Nickelsen's avatar Juergen Nickelsen
Browse files

Merge branch 'master' of git@git.w21.org:hsl

parents 6b38fb37 3c48fb90
#2345678901234567890123456789012345678901234567890123456789012345678901234567890
# 1 2 3 4 5 6 7 8
HEADERS = objects.h hashmap.h cbasics.h xmemory.h printer.h reader.h signals.h \
strbuf.h functions.h eval.h names.h builtins.h io.h repl.h
strbuf.h functions.h eval.h names.h builtins.h io.h repl.h gc.h \
tunables.h numbers.h
SOURCES = main.c hashmap.c xmemory.c objects.c printer.c reader.c signals.c \
strbuf.c vectors.c xdump.c eval.c builtins.c io.c repl.c
strbuf.c vectors.c xdump.c eval.c builtins.c io.c repl.c gc.c \
ob_common.c numbers.c
OBJECTS = $(subst .c,.o,$(SOURCES))
HOBJECTS = objects.o xmemory.o xdump.o strbuf.o
CFLAGS = -g
CC = gcc -Wall -Werror -Wstrict-prototypes -std=c99 #-m64
CFLAGS = -g# -O4 -DNDEBUG
CC = gcc -Wall -Werror -std=c99 -m64
TARGET = hsl
all: $(TARGET)
......@@ -18,5 +22,8 @@ $(OBJECTS): $(HEADERS) Makefile
hashmaptest: $(HOBJECTS) hashmap.c
$(CC) $(CFLAGS) -DHASHMAP_MAIN -o hashmaptest hashmap.c $(HOBJECTS)
test: $(TARGET) test/tests.lisp
./$(TARGET) test/tests.lisp
clean:
rm -f core core.* *~ *.o $(TARGET) cscope.out
......@@ -2,7 +2,49 @@
*: to do; +: done; -: rejected; @: in progress
* perhaps lambda (and mu) could be a special form that verifies a
* error handling: have some information in the interpreter context
(to be) that says if an error shall be printed or not and
things; it is saved, changed, and later restored e. g. by errset.
* a more useful tracing facility (eval, bindings, gc, gctraverse,
gcprotect, objects (new), ...)
* reentrant hashmap enumeration
* replace the out_port passed through everywhere by a more general
thing like a whole session context including input port and stuff
* format (seems not as difficult as it did)
(* destructuring let)
@ garbage collection
> (fac 400)
[GC... 235 marked, 28730 freed, 4 alloced, 28734 visited]
Error: invalid argument count; invalid number of arguments, 0 not in [2..-1]: #<builtin:-:2..>
#904: (- n 1)
[...]
#3: (fac (- n 1))
#2: (* n (fac (- n 1)))
#1: (if (zerop n) 1 (* n (fac (- n 1))))
#0: Segmentation fault
@ lots of builtins (to be refined)
* strbuf functions
* map functions
* vector functions
* flet
+ trace bit with functions
+ autoload
+ perhaps lambda (and mu) could be a special form that verifies a
function definition, same as defun, and mark the corresponding
pair as such, so we don't have to re-check it on every evalfun;
that does not make the form safe against modification, though.
......@@ -13,12 +55,10 @@
+ make map work
Done by finally implementing `function' and #' (and a reader
macro machanism in general)
macro mechanism in general)
+ reader bug causes SIGSEGV
@ lots of builtins (to be refined)
+ defun (like fset)
+ repeated evaluation of arguments, can bee seen when running
......@@ -26,5 +66,3 @@
(lambda (l) (if (eq (cdr l) nil) (car l) (last l)))
> (last '(3 4 5))
#<signal-LERROR,4:not a function object: 4>
* garbage collection
This diff is collapsed.
......@@ -8,8 +8,10 @@
#ifndef __BUILTINS_H_INC
#define __BUILTINS_H_INC
typedef obp_t builtin_func_t(obp_t args, obp_t out_port, int level);
typedef obp_t builtin_func_t(int nargs, obp_t args, obp_t out_port, int level);
obp_t register_builtin(char *name, builtin_func_t builtin,
int is_special, short minargs, short maxargs);
obp_t call_builtin(obp_t fun, obp_t args, obp_t out_port, int level);
void init_builtins(void);
......
......@@ -8,6 +8,10 @@
#define __EXTENSIONS__
#define __USE_POSIX
#define _GNU_SOURCE
//#define NDEBUG
typedef unsigned int uint;
typedef unsigned char uchar;
......
#include "cbasics.h"
#include <stdlib.h>
#include "objects.h"
#include "eval.h"
#include "signals.h"
......@@ -6,66 +8,87 @@
#include "hashmap.h"
#include "io.h"
#include "builtins.h"
#include "gc.h"
long eval_count = 0;
long apply_count = 0;
long bind_count = 0;
/**
* return NULL if argument is a proper function
* return a function object if argument is a proper function
*/
char *check_function(obp_t func)
obp_t make_function(char *name, uint namelen, obp_t func, obp_t out_port)
{
if (IS(func, BUILTIN)) {
return 0;
PROTECT;
short minargs = 0;
short maxargs = 0;
PROTVAR(retval);
if (IS(func, FUNCTION)) {
return func;
}
if (!IS(func, PAIR)) {
return "is not builtin or a list";
ERROR(out_port, ERR_NOFUNC, func,
"not function object or list");
}
obp_t marker = CAR(func);
if (marker != the_Lambda && marker != the_Mu) {
return "is not builtin or lambda or special form";
ERROR(out_port, ERR_NOFUNC, func,
"is not builtin or lambda or special form");
}
obp_t body = CDR(func);
if (!IS(body, PAIR)) {
return "lambda or special form body is not a list";
ERROR(out_port, ERR_NOFUNC, func,
"lambda or special form body is not a list");
}
obp_t arglist = CAR(body);
/* arglist of the form (sym sym sym) or (sym sym . sym) */
while (IS(arglist, PAIR)) {
obp_t sym = CAR(arglist);
if (!IS(sym, SYMBOL)) {
return "argument list member is not a symbol";
ERROR(out_port, ERR_NOFUNC, func,
"argument list member is not a symbol");
}
minargs++;
maxargs++;
arglist = CDR(arglist);
}
if (!IS_NIL(arglist) || !IS(arglist, SYMBOL)) {
return "argument list end not nil or symbol";
if (!IS_NIL(arglist)) {
if (IS(arglist, SYMBOL)) {
maxargs = -1;
} else {
ERROR(out_port, ERR_NOFUNC, func,
"argument list end not nil or symbol");
}
}
body = CDR(body);
while (IS(body, PAIR)) {
body = CDR(body);
}
if (!IS_NIL(body)) {
return "body is not a proper list";
ERROR(out_port, ERR_NOFUNC, func, "body is not a proper list");
}
return 0; /* phew... */
retval = new_form_function(name, namelen, func,
marker == the_Mu, minargs, maxargs);
EXIT:
UNPROTECT;
return retval;
}
void restore_bindings(obp_t saved_bindings, int level)
void restore_bindings(obp_t params, int nargs, obp_t out_port, int level)
{
hashmap_t syms = AS(saved_bindings, MAP)->map;
entptr_t ent;
if (traceflag) {
printf("%s* unbind ", blanks(level));
port_printf(out_port, "%s* unbind ", blanks(level));
}
hashmap_enum_start(syms);
while ((ent = hashmap_enum_next(syms))) {
obp_t symob = entry_get_key(ent);
Lsymbol_t *sym = AS(symob, SYMBOL);
sym->value = entry_get_value(ent);
while (nargs--) {
obp_t sym = CAR(params);
AS(sym, SYMBOL)->value = popup();
params = CDR(params);
if (traceflag) {
print_expr((obp_t) sym, 0);
port_print(the_Stdout, " to ");
print_expr(sym->value, 0);
print_expr(AS(sym, SYMBOL)->value, 0);
printf(", ");
}
}
......@@ -77,17 +100,20 @@ void restore_bindings(obp_t saved_bindings, int level)
obp_t make_bindings(obp_t params, obp_t args, obp_t out_port, int level)
{
obp_t saved_bindings = new_map(EQ_EQ, 0);
hashmap_t saved = AS(saved_bindings, MAP)->map;
PROTECT;
PROTVAR(retval);
if (traceflag) {
printf("%s* bind ", blanks(level));
}
while (!IS_NIL(args) && IS(params, PAIR)) {
int nargs = 0; /* number of bindings actually saved */
while (IS(args, PAIR) && IS(params, PAIR)) {
obp_t car = CAR(params);
Lsymbol_t *sym = AS(car, SYMBOL);
hashmap_put(saved, (obp_t) sym, sym->value);
pushdown(sym->value);
sym->value = CAR(args);
bind_count++;
nargs++;
if (traceflag) {
print_expr((obp_t) sym, 0);
port_print(the_Stdout, " to ");
......@@ -97,95 +123,154 @@ obp_t make_bindings(obp_t params, obp_t args, obp_t out_port, int level)
args = CDR(args);
params = CDR(params);
}
if (IS(params, SYMBOL)) {
Lsymbol_t *sym = AS(params, SYMBOL);
hashmap_put(saved, (obp_t) sym, sym->value);
sym->value = args;
if (traceflag) {
print_expr((obp_t) sym, 0);
port_print(the_Stdout, " to ");
print_expr(sym->value, 0);
port_print(the_Stdout, ", ");
if (!IS_NIL(params)) {
if (IS(params, SYMBOL)) {
Lsymbol_t *sym = AS(params, SYMBOL);
pushdown(sym->value);
sym->value = args;
bind_count++;
if (traceflag) {
print_expr((obp_t) sym, 0);
port_print(the_Stdout, " to ");
print_expr(sym->value, 0);
port_print(the_Stdout, ", ");
}
} else {
restore_bindings(params, nargs, out_port, level);
ERROR(out_port, ERR_NOARGS, 0,
"too few arguments for function");
}
} else {
if (args != the_Nil) {
restore_bindings(saved_bindings, level);
ERROR(out_port, ERR_INTERN, 0,
"too few arguments for function");
restore_bindings(params, nargs, out_port, level);
ERROR(out_port, ERR_NOARGS, 0,
"too many arguments for function");
}
}
if (traceflag) {
terpri(0);
}
return saved_bindings;
retval = new_integer(nargs);
EXIT:
UNPROTECT;
return retval;
}
obp_t apply(obp_t fun, obp_t args, obp_t out_port, int level)
{
obp_t value = the_Nil;
char *check = check_function(fun);
if (check) {
ERROR(out_port, ERR_NOFUNC, fun,
"apply: improper function, %s", check);
}
if (IS(fun, BUILTIN)) {
return call_builtin(fun, args, out_port, level);
} else {
obp_t body = CDR(fun); /* step over lambda */
obp_t params = CAR(body);
obp_t saved_bindings_or_error =
make_bindings(params, args, out_port, level);
CHECK_ERROR(saved_bindings_or_error);
PROTECT;
PROTVAR(retval);
PROTVAR(nargs);
apply_count++;
/* We need not check for fun being a function, because we already have
* a function object
*/
assert(IS(fun, FUNCTION));
if (IS_BUILTIN(fun)) {
retval = call_builtin(fun, args, out_port, level);
} else if (IS_FORM(fun)) {
obp_t form = AS(fun, FUNCTION)->impl.form;
obp_t body = CDR(form); /* step over form */
obp_t params = CAR(body); /* formal parameters */
nargs = make_bindings(params, args, out_port, level);
CHECK_ERROR(nargs);
while (IS((body = CDR(body)), PAIR)) {
value = eval(CAR(body), out_port, level + 1);
if (IS_ERROR(value)) {
break;
}
retval = eval(CAR(body), out_port, level);
CHECK_ERROR(retval);
}
restore_bindings(saved_bindings_or_error, level);
restore_bindings(params, (int) AS(nargs, NUMBER)->value,
out_port, level);
} else {
ERROR(out_port, ERR_NOFUNC, fun, "not a valid function");
}
return value;
EXIT:
UNPROTECT;
return retval;
}
#define IS_LAMBDA(ob) (IS(ob, PAIR) && CAR(ob) == the_Lambda)
#define IS_SPECIAL(ob) (IS(ob, PAIR) && CAR(ob) == the_Mu)
#define IS_MU(ob) (IS(ob, PAIR) && CAR(ob) == the_Mu)
obp_t autoload(obp_t fun, obp_t out_port, int level)
{
PROTECT;
PROTVAR(retval);
CHECKTYPE(out_port, fun, FUNCTION);
if (!IS_AUTOLOAD(fun)) {
ERROR(out_port, ERR_INVARG, fun, "not an autoload function");
}
Lfunction_t *func = AS(fun, FUNCTION);
retval = load_file(AS(func->impl.filename, STRING)->content,
out_port, level);
if (IS_ERROR(retval)) {
ERROR(out_port, ERR_NOAUTOL, fun, "load triggered error");
}
Lfunction_t *newfunc =
AS(AS(intern(func->name, func->namelen), SYMBOL)->function,
FUNCTION);
if (!newfunc) {
ERROR(out_port, ERR_NOAUTOL, fun, "function undefined");
}
if (newfunc->type == F_AUTOLOAD) {
ERROR(out_port, ERR_NOAUTOL, fun, "still not defined");
}
retval = (obp_t) newfunc;
EXIT:
UNPROTECT;
return retval;
}
obp_t evalfun(obp_t funob, obp_t args, obp_t out_port, int level)
obp_t evalfun(obp_t func, obp_t args, obp_t out_port, int level)
{
obp_t fun = funob;
if (IS(fun, PAIR)) {
if (!IS_LAMBDA(fun) && !IS_SPECIAL(fun)) {
fun = eval(fun, out_port, level + 1);
CHECK_ERROR(fun);
PROTECT;
PROTVAR(retval);
PROTVAR(ev_args); /* evaluated arguments */
PROTVAR(last); /* last element of list */
PROTVAR(value);
if (IS(func, PAIR)) {
if (!IS_LAMBDA(func) && !IS_MU(func)) {
func = eval(func, out_port, level);
CHECK_ERROR(func);
}
} else if (IS(fun, SYMBOL)) {
obp_t sym = fun;
fun = AS(sym, SYMBOL)->function;
if (fun == NULL) {
fun = AS(sym, SYMBOL)->value;
} else if (IS(func, SYMBOL)) {
obp_t sym = func;
func = AS(sym, SYMBOL)->function;
if (func == NULL) {
func = AS(sym, SYMBOL)->value;
}
if (fun == NULL) {
if (func == NULL) {
ERROR(out_port, ERR_NOFUNC, sym,
"symbol has no function definition");
}
}
if (IS_AUTOLOAD(func)) {
func = autoload(func, out_port, level);
CHECK_ERROR(func);
}
/* now we *should* have a function object of any kind */
if (!IS_LAMBDA(fun) && !IS_SPECIAL(fun) && !IS(fun, BUILTIN)) {
ERROR(out_port, ERR_NOFUNC, fun, "not a function object");
if (!IS(func, FUNCTION) && !IS_LAMBDA(func) && !IS_MU(func)) {
ERROR(out_port, ERR_NOFUNC, func, "not a function object");
}
/* now we should *have* a function object of any kind */
if (IS_LAMBDA(func) || IS_MU(func)) { /* may still be a constructed form! */
func = make_function(0, 0, func, out_port);
CHECK_ERROR(func);
} else if (!IS(func, FUNCTION)) {
ERROR(out_port, ERR_NOFUNC, func, "not a function object");
}
/* now we *have* a function object of any kind */
if (IS_LAMBDA(fun) ||
(IS(fun, BUILTIN) && !AS(fun, BUILTIN)->is_special))
{
if (!IS_SPECIAL(func)) {
/* must evaluate arguments */
obp_t ev_args = the_Nil; /* evaluated arguments */
obp_t last = the_Nil;
for (obp_t elem = args; IS(elem, PAIR); elem = CDR(elem)) {
obp_t value = eval(CAR(elem), out_port, level + 1);
value = eval(CAR(elem), out_port, level);
CHECK_ERROR(value);
if (ev_args == the_Nil) {
ev_args = last = new_pair(value, the_Nil);
......@@ -197,28 +282,46 @@ obp_t evalfun(obp_t funob, obp_t args, obp_t out_port, int level)
}
args = ev_args;
}
return apply(fun, args, out_port, level);
if (AS(func, FUNCTION)->trace) {
strbuf_t sb = strbuf_new();
sb = s_expr(func, sb, 0);
port_printf(out_port, "%s(%s", blanks(level), strbuf_string(sb));
for (obp_t elem = ev_args; IS(elem, PAIR); elem = CDR(elem)) {
strbuf_reinit(sb);
sb = s_expr(elem, sb, 0);
port_printf(out_port, " %s", strbuf_string(sb));
}
port_printf(out_port, ")\n");
free(sb);
}
retval = apply(func, args, out_port, level);
EXIT:
UNPROTECT;
return retval;
}
obp_t eval(obp_t ob, obp_t out_port, int level)
{
obp_t value;
PROTECT;
PROTVAR(retval);
Lpair_t *pair;
eval_count++;
if (traceflag) {
port_printf(out_port, "%seval[%d]", blanks(level), level);
}
switch (ob->type) {
case SYMBOL:
value = AS(ob, SYMBOL)->value;
if (!value) {
retval = AS(ob, SYMBOL)->value;
if (!retval) {
ERROR(out_port, ERR_EVAL, ob, "symbol undefined");
}
if (traceflag) {
print_expr(new_zstring(" sym: "), out_port);
print_expr(ob, out_port);
print_expr(new_zstring(" = "), out_port);
print_expr(value, out_port);
print_expr(retval, out_port);
terpri(out_port);
}
break;
......@@ -229,7 +332,7 @@ obp_t eval(obp_t ob, obp_t out_port, int level)
print_expr(ob, out_port);
terpri(out_port);
}
value = evalfun(pair->car, pair->cdr, out_port, level);
retval = evalfun(pair->car, pair->cdr, out_port, level + 1);
break;
default:
if (traceflag) {
......@@ -237,20 +340,23 @@ obp_t eval(obp_t ob, obp_t out_port, int level)
print_expr(ob, out_port);
terpri(out_port);
}
value = ob;
retval = ob;
break;
}
if (traceflag) {
port_printf(out_port,
"%s=val[%d] ", blanks(level), level);
print_expr(value, out_port);
print_expr(retval, out_port);
terpri(out_port);
} else if (IS_ERROR(value)) {
} else if (IS_EXIT(retval)) {
port_printf(out_port, "#%d: ", level);
print_expr(ob, out_port);
terpri(out_port);
}
return value;
EXIT:
UNPROTECT;
return retval;
}
/* EOF */
......@@ -2,10 +2,20 @@
#include "objects.h"
#include "io.h"
extern long eval_count;
extern long apply_count;
extern long bind_count;
// obp_t evalfun(obp_t fun, obp_t args);
obp_t eval(obp_t ob, obp_t out_port, int level);
obp_t apply(obp_t fun, obp_t args, obp_t out_port, int level);
obp_t make_bindings(obp_t params, obp_t args, obp_t out_port, int level);
void restore_bindings(obp_t params, int nargs, obp_t out_port, int level);
/**
* return NULL if argument is a proper function
*/
char *check_function(obp_t func);
obp_t make_function(char *name, uint namelen, obp_t func, obp_t out_port);
#include "cbasics.h"
#include <stdlib.h>
#include "objects.h"
#include "xmemory.h"
#include "gc.h"
#include "printer.h"
gcp_t gc_prot_root;
gcp_t gc_start_protect(char *file, int line)
{
if (traceflag) {
printf("PROTECT %s:%d:%p\n", file, line, gc_prot_root);
}
return gc_prot_root;
}
void gc_protect(char *what, int line, obp_t *obpp)
{
if (traceflag) {
printf("protect %s:%d:%p\n", what, line, obpp);
}
gcp_t newp = (gcp_t) new_object(sizeof(struct GCPROT), GCPROT);
newp->item.obpp = obpp;
newp->next = gc_prot_root;
newp->is_obpp = 1;
gc_prot_root = newp;
}
void gc_unprotect(gcp_t prot_state, char *file, int line)
{
gc_prot_root = prot_state;
if (traceflag) {
printf("UNPROTECT %s:%d:%