Commit 720c29a9 authored by Juergen Nickelsen's avatar Juergen Nickelsen
Browse files

Merge branch 'master' of git.w21.org:lisp/hsl

parents 7d8364a6 53ca9308
# Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
# See the file COPYRIGHT for details.
#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 gc.h \
strbuf.h functions.h eval.h names.h builtins.h io.h session.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 gc.c \
strbuf.c vectors.c xdump.c eval.c builtins.c io.c session.c gc.c \
ob_common.c numbers.c
OBJECTS = $(subst .c,.o,$(SOURCES))
HOBJECTS = objects.o xmemory.o xdump.o strbuf.o
CFLAGS = -g# -O4 -DNDEBUG
CFLAGS = -g -O # -O4 -DNDEBUG
LDLIBS = -lm
CC = gcc -Wall -Werror -std=c99 -m64
TARGET = hsl
......
......@@ -41,7 +41,11 @@
* vector functions
* flet
* flet, label
+ bug:
> (* 26 .305)
26
+ trace bit with functions
......
This diff is collapsed.
/* Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
* See the file COPYRIGHT for details.
*/
/**
* Builtin functions exist as a C function "bf_funcname" and as the
* corresponding object B_funcname.
* Builtin functions
*/
#include "cbasics.h"
#ifndef __BUILTINS_H_INC
#define __BUILTINS_H_INC
typedef obp_t builtin_func_t(int nargs, obp_t args, obp_t out_port, int level);
#include "cbasics.h"
#include "session.h"
typedef obp_t builtin_func_t(int nargs, obp_t args,
session_context_t *sc, 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);
obp_t call_builtin(obp_t fun, obp_t args, session_context_t *sc, int level);
void init_builtins(void);
#endif /* __BUILTINS_H_INC */
......
/* Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
* See the file COPYRIGHT for details.
*/
/*
* basic C definitions needed here and there; must be self-contained so we can
* include it at the top of every module
......
/* Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
* See the file COPYRIGHT for details.
*/
#include "cbasics.h"
#include <stdlib.h>
......@@ -17,7 +20,7 @@ long bind_count = 0;
/**
* return a function object if argument is a proper function
*/
obp_t make_function(char *name, uint namelen, obp_t func, obp_t out_port)
obp_t make_function(char *name, uint namelen, obp_t func, session_context_t *sc)
{
PROTECT;
short minargs = 0;
......@@ -28,17 +31,16 @@ obp_t make_function(char *name, uint namelen, obp_t func, obp_t out_port)
return func;
}
if (!IS(func, PAIR)) {
ERROR(out_port, ERR_NOFUNC, func,
"not function object or list");
ERROR(sc->out, ERR_NOFUNC, func, "not function object or list");
}
obp_t marker = CAR(func);
if (marker != the_Lambda && marker != the_Mu) {
ERROR(out_port, ERR_NOFUNC, func,
ERROR(sc->out, ERR_NOFUNC, func,
"is not builtin or lambda or special form");
}
obp_t body = CDR(func);
if (!IS(body, PAIR)) {
ERROR(out_port, ERR_NOFUNC, func,
ERROR(sc->out, ERR_NOFUNC, func,
"lambda or special form body is not a list");
}
obp_t arglist = CAR(body);
......@@ -46,7 +48,7 @@ obp_t make_function(char *name, uint namelen, obp_t func, obp_t out_port)
while (IS(arglist, PAIR)) {
obp_t sym = CAR(arglist);
if (!IS(sym, SYMBOL)) {
ERROR(out_port, ERR_NOFUNC, func,
ERROR(sc->out, ERR_NOFUNC, func,
"argument list member is not a symbol");
}
minargs++;
......@@ -57,7 +59,7 @@ obp_t make_function(char *name, uint namelen, obp_t func, obp_t out_port)
if (IS(arglist, SYMBOL)) {
maxargs = -1;
} else {
ERROR(out_port, ERR_NOFUNC, func,
ERROR(sc->out, ERR_NOFUNC, func,
"argument list end not nil or symbol");
}
}
......@@ -66,7 +68,7 @@ obp_t make_function(char *name, uint namelen, obp_t func, obp_t out_port)
body = CDR(body);
}
if (!IS_NIL(body)) {
ERROR(out_port, ERR_NOFUNC, func, "body is not a proper list");
ERROR(sc->out, ERR_NOFUNC, func, "body is not a proper list");
}
retval = new_form_function(name, namelen, func,
marker == the_Mu, minargs, maxargs);
......@@ -76,10 +78,10 @@ obp_t make_function(char *name, uint namelen, obp_t func, obp_t out_port)
}
void restore_bindings(obp_t params, int nargs, obp_t out_port, int level)
void restore_bindings(obp_t params, int nargs, session_context_t *sc, int level)
{
if (traceflag) {
port_printf(out_port, "%s* unbind ", blanks(level));
port_printf(sc->out, "%s* unbind ", blanks(level));
}
while (nargs--) {
obp_t sym = CAR(params);
......@@ -98,7 +100,7 @@ void restore_bindings(obp_t params, int nargs, obp_t out_port, int level)
}
obp_t make_bindings(obp_t params, obp_t args, obp_t out_port, int level)
obp_t make_bindings(obp_t params, obp_t args, session_context_t *sc, int level)
{
PROTECT;
PROTVAR(retval);
......@@ -136,14 +138,14 @@ obp_t make_bindings(obp_t params, obp_t args, obp_t out_port, int level)
port_print(the_Stdout, ", ");
}
} else {
restore_bindings(params, nargs, out_port, level);
ERROR(out_port, ERR_NOARGS, 0,
restore_bindings(params, nargs, sc, level);
ERROR(sc->out, ERR_NOARGS, 0,
"too few arguments for function");
}
} else {
if (args != the_Nil) {
restore_bindings(params, nargs, out_port, level);
ERROR(out_port, ERR_NOARGS, 0,
restore_bindings(params, nargs, sc, level);
ERROR(sc->out, ERR_NOARGS, 0,
"too many arguments for function");
}
}
......@@ -157,7 +159,7 @@ obp_t make_bindings(obp_t params, obp_t args, obp_t out_port, int level)
}
obp_t apply(obp_t fun, obp_t args, obp_t out_port, int level)
obp_t apply(obp_t fun, obp_t args, session_context_t *sc, int level)
{
PROTECT;
PROTVAR(retval);
......@@ -169,22 +171,22 @@ obp_t apply(obp_t fun, obp_t args, obp_t out_port, int level)
*/
assert(IS(fun, FUNCTION));
if (IS_BUILTIN(fun)) {
retval = call_builtin(fun, args, out_port, level);
retval = call_builtin(fun, args, sc, 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);
nargs = make_bindings(params, args, sc, level);
CHECK_ERROR(nargs);
while (IS((body = CDR(body)), PAIR)) {
retval = eval(CAR(body), out_port, level);
retval = eval(CAR(body), sc, level);
CHECK_ERROR(retval);
}
restore_bindings(params, (int) AS(nargs, NUMBER)->value,
out_port, level);
sc, level);
} else {
ERROR(out_port, ERR_NOFUNC, fun, "not a valid function");
ERROR(sc->out, ERR_NOFUNC, fun, "not a valid function");
}
EXIT:
UNPROTECT;
......@@ -196,29 +198,28 @@ obp_t apply(obp_t fun, obp_t args, obp_t out_port, int level)
#define IS_MU(ob) (IS(ob, PAIR) && CAR(ob) == the_Mu)
obp_t autoload(obp_t fun, obp_t out_port, int level)
obp_t autoload(obp_t fun, session_context_t *sc, int level)
{
PROTECT;
PROTVAR(retval);
CHECKTYPE(out_port, fun, FUNCTION);
CHECKTYPE(sc->out, fun, FUNCTION);
if (!IS_AUTOLOAD(fun)) {
ERROR(out_port, ERR_INVARG, fun, "not an autoload function");
ERROR(sc->out, 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);
retval = load_file(AS(func->impl.filename, STRING)->content, sc, level);
if (IS_ERROR(retval)) {
ERROR(out_port, ERR_NOAUTOL, fun, "load triggered error");
ERROR(sc->out, 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");
ERROR(sc->out, ERR_NOAUTOL, fun, "function undefined");
}
if (newfunc->type == F_AUTOLOAD) {
ERROR(out_port, ERR_NOAUTOL, fun, "still not defined");
ERROR(sc->out, ERR_NOAUTOL, fun, "still not defined");
}
retval = (obp_t) newfunc;
EXIT:
......@@ -227,7 +228,7 @@ obp_t autoload(obp_t fun, obp_t out_port, int level)
}
obp_t evalfun(obp_t func, obp_t args, obp_t out_port, int level)
obp_t evalfun(obp_t func, obp_t args, session_context_t *sc, int level)
{
PROTECT;
PROTVAR(retval);
......@@ -237,7 +238,7 @@ obp_t evalfun(obp_t func, obp_t args, obp_t out_port, int level)
if (IS(func, PAIR)) {
if (!IS_LAMBDA(func) && !IS_MU(func)) {
func = eval(func, out_port, level);
func = eval(func, sc, level);
CHECK_ERROR(func);
}
} else if (IS(func, SYMBOL)) {
......@@ -247,30 +248,30 @@ obp_t evalfun(obp_t func, obp_t args, obp_t out_port, int level)
func = AS(sym, SYMBOL)->value;
}
if (func == NULL) {
ERROR(out_port, ERR_NOFUNC, sym,
ERROR(sc->out, ERR_NOFUNC, sym,
"symbol has no function definition");
}
}
if (IS_AUTOLOAD(func)) {
func = autoload(func, out_port, level);
func = autoload(func, sc, level);
CHECK_ERROR(func);
}
/* now we *should* have a function object of any kind */
if (!IS(func, FUNCTION) && !IS_LAMBDA(func) && !IS_MU(func)) {
ERROR(out_port, ERR_NOFUNC, func, "not a function object");
ERROR(sc->out, ERR_NOFUNC, func, "not a function object");
}
if (IS_LAMBDA(func) || IS_MU(func)) { /* may still be a constructed form! */
func = make_function(0, 0, func, out_port);
func = make_function(0, 0, func, sc);
CHECK_ERROR(func);
} else if (!IS(func, FUNCTION)) {
ERROR(out_port, ERR_NOFUNC, func, "not a function object");
ERROR(sc->out, ERR_NOFUNC, func, "not a function object");
}
/* now we *have* a function object of any kind */
if (!IS_SPECIAL(func)) {
/* must evaluate arguments */
for (obp_t elem = args; IS(elem, PAIR); elem = CDR(elem)) {
value = eval(CAR(elem), out_port, level);
value = eval(CAR(elem), sc, level);
CHECK_ERROR(value);
if (ev_args == the_Nil) {
ev_args = last = new_pair(value, the_Nil);
......@@ -285,23 +286,23 @@ obp_t evalfun(obp_t func, obp_t args, obp_t out_port, int 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));
port_printf(sc->out, "%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(sc->out, " %s", strbuf_string(sb));
}
port_printf(out_port, ")\n");
port_printf(sc->out, ")\n");
free(sb);
}
retval = apply(func, args, out_port, level);
retval = apply(func, args, sc, level);
EXIT:
UNPROTECT;
return retval;
}
obp_t eval(obp_t ob, obp_t out_port, int level)
obp_t eval(obp_t ob, session_context_t *sc, int level)
{
PROTECT;
PROTVAR(retval);
......@@ -309,49 +310,49 @@ obp_t eval(obp_t ob, obp_t out_port, int level)
eval_count++;
if (traceflag) {
port_printf(out_port, "%seval[%d]", blanks(level), level);
port_printf(sc->out, "%seval[%d]", blanks(level), level);
}
switch (ob->type) {
case SYMBOL:
retval = AS(ob, SYMBOL)->value;
if (!retval) {
ERROR(out_port, ERR_EVAL, ob, "symbol undefined");
ERROR(sc->out, 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(retval, out_port);
terpri(out_port);
print_expr(new_zstring(" sym: "), sc->out);
print_expr(ob, sc->out);
print_expr(new_zstring(" = "), sc->out);
print_expr(retval, sc->out);
terpri(sc->out);
}
break;
case PAIR:
pair = AS(ob, PAIR);
if (traceflag) {
print_expr(new_zstring(" pair: "), out_port);
print_expr(ob, out_port);
terpri(out_port);
print_expr(new_zstring(" pair: "), sc->out);
print_expr(ob, sc->out);
terpri(sc->out);
}
retval = evalfun(pair->car, pair->cdr, out_port, level + 1);
retval = evalfun(pair->car, pair->cdr, sc, level + 1);
break;
default:
if (traceflag) {
print_expr(new_zstring(" other: "), out_port);
print_expr(ob, out_port);
terpri(out_port);
print_expr(new_zstring(" other: "), sc->out);
print_expr(ob, sc->out);
terpri(sc->out);
}
retval = ob;
break;
}
if (traceflag) {
port_printf(out_port,
port_printf(sc->out,
"%s=val[%d] ", blanks(level), level);
print_expr(retval, out_port);
terpri(out_port);
print_expr(retval, sc->out);
terpri(sc->out);
} else if (IS_EXIT(retval)) {
port_printf(out_port, "#%d: ", level);
print_expr(ob, out_port);
terpri(out_port);
port_printf(sc->out, "#%d: ", level);
print_expr(ob, sc->out);
terpri(sc->out);
}
EXIT:
UNPROTECT;
......
/* Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
* See the file COPYRIGHT for details.
*/
#include "objects.h"
#include "io.h"
......@@ -7,15 +10,15 @@ 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 eval(obp_t ob, session_context_t *sc, int level);
obp_t apply(obp_t fun, obp_t args, obp_t out_port, int level);
obp_t apply(obp_t fun, obp_t args, session_context_t *sc, 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);
obp_t make_bindings(obp_t params, obp_t args, session_context_t *sc, int level);
void restore_bindings(obp_t params, int nargs, session_context_t *sc, int level);
/**
* return NULL if argument is a proper function
*/
obp_t make_function(char *name, uint namelen, obp_t func, obp_t out_port);
obp_t make_function(char *name, uint namelen, obp_t func, session_context_t *sc);
/* Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
* See the file COPYRIGHT for details.
*/
#include "cbasics.h"
#include <sys/types.h>
......
/* Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
* See the file COPYRIGHT for details.
*/
#include "cbasics.h"
#include <stdlib.h>
......
/* Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
* See the file COPYRIGHT for details.
*/
#ifndef __GC_H_INC
#define __GC_H_INC
......
/* Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
* See the file COPYRIGHT for details.
*/
#include "cbasics.h"
#include <stdio.h>
......
/* Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
* See the file COPYRIGHT for details.
*/
/*
* Map with objects as keys and values. A map may be weak (not keeping key
* objects from being gced).
......
/* Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
* See the file COPYRIGHT for details.
*/
#include "cbasics.h"
#include <stdio.h>
......@@ -13,7 +16,7 @@
#include "xmemory.h"
#include "reader.h"
#include "eval.h"
#include "repl.h"
#include "session.h"
#include "gc.h"
obp_t the_Stdin;
......@@ -212,7 +215,7 @@ obp_t port_getc(obp_t port)
obp_t port_read(obp_t port, uint len)
{
Lport_t *p = AS(port, PORT);
char *read_buf;
char *read_buf = 0;
int read_ret;
PROTVAR(retval);
......@@ -289,15 +292,21 @@ obp_t close_port(obp_t port)
return retval;
}
obp_t load_file(char *fname, obp_t out_port, int level)
obp_t load_file(char *fname, session_context_t *sc, int level)
{
PROTECT;
PROTVAR(retval);
PROTVAL(port, make_stream_port(fname, "r"));
CHECK_ERROR(port);
retval = repl(port, out_port, 0, level);
close_port(port);
PROTVAL(new_in, make_stream_port(fname, "r"));
CHECK_ERROR(new_in);
PROTVAL(saved_port, sc->in);
int saved_int = sc->is_interactive;
sc->in = new_in;
sc->is_interactive = 0;
retval = repl(sc, level);
close_port(new_in);
sc->is_interactive = saved_int;
sc->in = saved_port;
EXIT:
UNPROTECT;
return retval;
......
/* Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
* See the file COPYRIGHT for details.
*/
#include <stdarg.h>
#include "objects.h"
#include "session.h"
#define IO_READ 0
#define IO_WRITE 1
......@@ -26,4 +30,4 @@ obp_t port_ungetc(obp_t port, int c);
char *port_type_name(port_type_t type);
obp_t port_tty(obp_t port);
obp_t port_flush(obp_t port);
obp_t load_file(char *fname, obp_t out_port, int level);
obp_t load_file(char *fname, session_context_t *sc, int level);
/* Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
* See the file COPYRIGHT for details.
*/
/*
* here be main()
*/
......@@ -8,7 +11,7 @@
#include <sysexits.h>
#include "builtins.h"
#include "io.h"
#include "repl.h"
#include "session.h"
#include "reader.h"
#include "signals.h"
#include "printer.h"
......@@ -74,7 +77,10 @@ int main(int argc, char *argv[])
obp_t val = the_Nil;
if (argc > 1) {
while (*++argv) {
val = load_file(*argv, the_Stderr, 0);
session_context_t *sc =
new_session(the_Stdin, the_Stderr, 0);
val = load_file(*argv, sc, 0);
free_session(sc);
if (IS_EXIT(val)) {
print_expr(val, the_Stderr);
terpri(the_Stderr);
......@@ -83,7 +89,9 @@ int main(int argc, char *argv[])
file_arguments = 1;
}
if (!file_arguments || opt_interactive) {
val = repl(the_Stdin, the_Stdout, 1, 0);
session_context_t *sc = new_session(the_Stdin, the_Stdout, 1);
val = repl(sc, 0);
free_session(sc);
}
return val == the_Nil;
}
/* Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
* See the file COPYRIGHT for details.
*/
#define STDOUT_PORT_NAME "*stdout-port*"
#define STDERR_PORT_NAME "*stderr-port*"
......@@ -77,3 +80,5 @@
#define GC_NAME "gc"
#define TRACE_FUNCTION_NAME "trace-function"
#define SHOW_FREELIST_NAME "show-freelist"
#define SUCCESSOR_NAME "1+"
#define PREDECESSOR_NAME "1-"
/* Copyright (c) 2010, 2011 Juergen Nickelsen <ni@jnickelsen.de>
* See the file COPYRIGHT for details.
*/
#include "cbasics.h"
#include <math.h>
......@@ -15,13 +18,13 @@
* 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)
obp_t bf_plus(int nargs, obp_t args, session_context_t *sc, int level)
{
long double value = 0;
int is_int = 1;
while (!IS_NIL(args)) {
obp_t arg = CAR(args);
CHECKTYPE_RET(out_port, arg, NUMBER);
CHECKTYPE_RET(sc->out, arg, NUMBER);
value += AS(arg, NUMBER)->value;
is_int &= IS_INT(arg) && INTRANGE(value);
args = CDR(args);
......@@ -31,21 +34,49 @@ obp_t bf_plus(int nargs, obp_t args, obp_t out_port, int level)
return newval;
}
/**
* Return a number that is one more than its argument number.
* (1+ number)
*/
obp_t bf_successor(int nargs, obp_t args, session_context_t *sc, int level)
{
obp_t arg = CAR(args);
long double value = AS(arg, NUMBER)->value + 1;