LakeVal *apply(LakeCtx *ctx, LakeVal *fnVal, LakeList *args)
{
LakeVal *result = NULL;
if (lake_is_type(TYPE_PRIM, fnVal)) {
LakePrimitive *prim = PRIM(fnVal);
int arity = prim->arity;
if (arity == ARITY_VARARGS || LIST_N(args) == arity) {
result = prim->fn(ctx, args);
}
else {
ERR("%s expects %d params but got %zu", prim->name, arity, LIST_N(args));
result = NULL;
}
}
else if (lake_is_type(TYPE_FN, fnVal)) {
LakeFn *fn = FN(fnVal);
/* Check # of params */
size_t nparams = LIST_N(fn->params);
if (!fn->varargs && LIST_N(args) != nparams) {
ERR("expected %zu params but got %zu", nparams, LIST_N(args));
return NULL;
}
else if (fn->varargs && LIST_N(args) < nparams) {
ERR("expected at least %zu params but got %zu", nparams, LIST_N(args));
return NULL;
}
Env *env = env_make(fn->closure);
/* bind each (param,arg) pair in env */
size_t i;
for (i = 0; i < nparams; ++i) {
env_define(env, SYM(LIST_VAL(fn->params, i)), LIST_VAL(args, i));
}
/* bind varargs */
if (fn->varargs) {
LakeList *remainingArgs = list_make_with_capacity(LIST_N(args) - nparams);
for (; i < LIST_N(args); ++i) {
list_append(remainingArgs, LIST_VAL(args, i));
}
env_define(env, fn->varargs, VAL(remainingArgs));
}
/* evaluate body */
result = eval_exprs1(ctx, env, fn->body);
}
else {
ERR("not a function: %s", lake_repr(fnVal));
}
return result;
}
static pobject define(pobject env, pobject params)
{
pobject p = cons_car(params);
if (is_symbol(p)) {
return env_define(env,
cons_car(params),
eval(env, cons_car(cons_cdr(params))));
} else if (is_cons(p)) {
return env_define(env,
cons_car(p),
gc_add(closure_new(env, cons_cdr(p), cons_cdr(params))));
}
return NIL;
}
static void define_primitive(struct env *env, char *symbol,
struct exp *(*function)(struct exp *args)) {
struct exp *e = (*gc->alloc_exp)(FUNCTION);
e->value.function.fn = function;
e->value.function.name = malloc(strlen(symbol) + 1);
strcpy(e->value.function.name, symbol);
env_define(env, exp_make_atom(symbol), e);
}
static pobject defmacro(pobject env, pobject params)
{
pobject p = cons_car(params);
if (is_cons(p)) {
return env_define(env,
cons_car(p),
gc_add(macro_new(env, cons_cdr(p), cons_cdr(params))));
}
return NIL;
}
static LakeVal *_define(LakeCtx *ctx, Env *env, LakeList *expr)
{
/* TODO: make these more robust, check all expected params */
/* (define x 42) */
if (LIST_N(expr) == 3 && lake_is_type(TYPE_SYM, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "define" symbol */
LakeSym *var = SYM(list_shift(expr));
LakeVal *form = list_shift(expr);
env_define(env, var, eval(ctx, env, form));
}
/* (define (inc x) (+ 1 x)) */
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_LIST, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "define" symbol */
LakeList *params = LIST(list_shift(expr));
LakeSym *var = SYM(list_shift(params));
LakeList *body = expr;
env_define(env, var, VAL(fn_make(params, NULL, body, env)));
}
/* (define (print format . args) (...)) */
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_DLIST, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "define" symbol */
LakeDottedList *def = DLIST(list_shift(expr));
LakeList *params = dlist_head(def);
LakeSym *varargs = SYM(dlist_tail(def));
LakeSym *var = SYM(list_shift(params));
LakeList *body = expr;
env_define(env, var, VAL(fn_make(params, varargs, body, env)));
}
else {
invalid_special_form(expr, "define requires at least 2 parameters");
}
return NULL;
}
int
eval_instruction(struct vm_context **ctx)
{
struct symbol *sym;
struct object *value;
struct compound_proc *template;
switch (INS_AT((*ctx)->pc)->op) {
case NONE:
printf("Error: tried to execute a NONE op\n");
exit(1);
break;
case PUSH:
/* printf("PUSH instruction\n"); */
stack_push((*ctx)->stk, INS_AT((*ctx)->pc)->arg);
INC_REF(INS_AT((*ctx)->pc)->arg);
++(*ctx)->pc->offset;
break;
case POP:
/* printf("POP instruction\n"); */
value = stack_pop((*ctx)->stk);
DEC_REF(value);
++(*ctx)->pc->offset;
break;
case LOOKUP:
/* printf("LOOKUP instruction\n"); */
assert(INS_AT((*ctx)->pc)->arg->type->code == SYMBOL_TYPE);
sym = container_of(INS_AT((*ctx)->pc)->arg, struct symbol, obj);
value = env_lookup((*ctx)->env, sym->value);
if (! value) {
char buf[1024];
debug_loc_str(INS_AT((*ctx)->pc)->arg, buf, 1024);
printf("%s: unbound name: %s\n", buf, sym->value);
exit(1);
}
stack_push((*ctx)->stk, value);
INC_REF(value);
++(*ctx)->pc->offset;
break;
case CALL:
case TAILCALL:
/* printf("CALL instruction @ %p\n", *pc); */
eval_call(ctx);
break;
case RET:
value = stack_pop((*ctx)->stk);
struct object *orig_env = stack_pop((*ctx)->stk);
assert(orig_env->type->code == ENVIRONMENT_TYPE);
DEC_REF(orig_env);
struct object *retaddr = stack_pop((*ctx)->stk);
/* printf("RET instruction @ %p to %p\n", *pc, retaddr->cval); */
stack_push((*ctx)->stk, value);
DEC_REF(&(*ctx)->env->obj);
(*ctx)->env = container_of(orig_env, struct environment, obj);
if (retaddr == NULL) {
(*ctx)->pc = NULL;
return 1;
}
assert(retaddr->type->code == CODEPTR_TYPE);
*(*ctx)->pc = *container_of(retaddr, struct codeptr, obj);
/* XXX: */
/* DEC_REF(retaddr); */
break;
case DEFINE:
/* printf("DEFINE instruction\n"); */
value = stack_pop((*ctx)->stk);
assert(INS_AT((*ctx)->pc)->arg->type->code == SYMBOL_TYPE);
sym = container_of(INS_AT((*ctx)->pc)->arg, struct symbol, obj);
env_define((*ctx)->env, sym->value, value);
DEC_REF(value);
++(*ctx)->pc->offset;
break;
case SET:
value = stack_pop((*ctx)->stk);
assert(INS_AT((*ctx)->pc)->arg->type->code == SYMBOL_TYPE);
sym = container_of(INS_AT((*ctx)->pc)->arg, struct symbol, obj);
env_set((*ctx)->env, sym->value, value);
DEC_REF(value);
++(*ctx)->pc->offset;
break;
case LAMBDA:
/* printf("LAMBDA instruction\n"); */
value = INS_AT((*ctx)->pc)->arg;
assert(INS_AT((*ctx)->pc)->arg->type->code == PROCEDURE_TYPE);
void env_intern_define(Environment *e, const char *name, GCPtr value) {
env_define(e,intern_symbol(name), value);
}
int
main(int argc, char **argv)
{
int ch;
char *user;
setprogname(argv[0]);
#ifdef KRB5
krb5_init();
#endif
tninit(); /* Clear out things */
TerminalSaveState();
if ((prompt = strrchr(argv[0], '/')))
++prompt;
else
prompt = argv[0];
user = NULL;
rlogin = (strncmp(prompt, "rlog", 4) == 0) ? '~' : _POSIX_VDISABLE;
/*
* if AUTHENTICATION and ENCRYPTION is set autologin will be
* se to true after the getopt switch; unless the -K option is
* passed
*/
autologin = -1;
if (argc == 2 && strcmp(argv[1], "--version") == 0) {
print_version(NULL);
exit(0);
}
if (argc == 2 && strcmp(argv[1], "--help") == 0)
usage(0);
while((ch = getopt(argc, argv,
"78DEKLS:X:abcde:fFk:l:n:rxG")) != -1) {
switch(ch) {
case '8':
eight = 3; /* binary output and input */
break;
case '7':
eight = 0;
break;
case 'b':
binary = 3;
break;
case 'D': {
/* sometimes we don't want a mangled display */
char *p;
if((p = getenv("DISPLAY")))
env_define((unsigned char*)"DISPLAY", (unsigned char*)p);
break;
}
case 'E':
rlogin = escape = _POSIX_VDISABLE;
break;
case 'K':
#ifdef AUTHENTICATION
autologin = 0;
#endif
break;
case 'L':
eight |= 2; /* binary output only */
break;
case 'S':
{
#ifdef HAVE_PARSETOS
extern int tos;
if ((tos = parsetos(optarg, "tcp")) < 0)
fprintf(stderr, "%s%s%s%s\n",
prompt, ": Bad TOS argument '",
optarg,
"; will try to use default TOS");
#else
fprintf(stderr,
"%s: Warning: -S ignored, no parsetos() support.\n",
prompt);
#endif
}
break;
case 'X':
#ifdef AUTHENTICATION
auth_disable_name(optarg);
#endif
break;
case 'a':
autologin = 1;
break;
case 'c':
skiprc = 1;
break;
case 'd':
debug = 1;
break;
case 'e':
set_escape_char(optarg);
break;
case 'f':
case 'F':
case 'G':
#if defined(AUTHENTICATION) && defined(KRB5) && defined(FORWARD)
if (forward_option) {
fprintf(stderr,
"%s: Only one of -f, -F and -G allowed.\n",
prompt);
usage(1);
}
forward_option = ch;
#else
fprintf(stderr,
"%s: Warning: -%c ignored, no Kerberos V5 support.\n",
prompt, ch);
#endif
break;
case 'k':
#if defined(AUTHENTICATION) && defined(KRB4)
{
dest_realm = dst_realm_buf;
strlcpy(dest_realm, optarg, dst_realm_sz);
}
#else
fprintf(stderr,
"%s: Warning: -k ignored, no Kerberos V4 support.\n",
prompt);
#endif
break;
case 'l':
if(autologin == 0){
fprintf(stderr, "%s: Warning: -K ignored\n", prompt);
autologin = -1;
}
user = optarg;
break;
case 'n':
SetNetTrace(optarg);
break;
case 'r':
rlogin = '******';
break;
case 'x':
#ifdef ENCRYPTION
encrypt_auto(1);
decrypt_auto(1);
wantencryption = 1;
EncryptVerbose(1);
#else
fprintf(stderr,
"%s: Warning: -x ignored, no ENCRYPT support.\n",
prompt);
#endif
break;
case '?':
default:
usage(1);
/* NOTREACHED */
}
}
if (autologin == -1) { /* [email protected]; force */
#if defined(AUTHENTICATION)
autologin = 1;
#endif
#if defined(ENCRYPTION)
encrypt_auto(1);
decrypt_auto(1);
wantencryption = -1;
#endif
}
if (autologin == -1)
autologin = (rlogin == _POSIX_VDISABLE) ? 0 : 1;
argc -= optind;
argv += optind;
if (argc) {
char *args[7], **argp = args;
if (argc > 2)
usage(1);
*argp++ = prompt;
if (user) {
*argp++ = "-l";
*argp++ = user;
}
*argp++ = argv[0]; /* host */
if (argc > 1)
*argp++ = argv[1]; /* port */
*argp = 0;
if (setjmp(toplevel) != 0)
Exit(0);
if (tn(argp - args, args) == 1)
return (0);
else
return (1);
}
setjmp(toplevel);
for (;;) {
command(1, 0, 0);
}
}
/*
* main. Parse arguments, invoke the protocol or command parser.
*/
int
main (int argc, char *argv[])
{
int ch;
char *user, *alias;
#ifdef FORWARD
extern int forward_flags;
#endif /* FORWARD */
tninit (); /* Clear out things */
TerminalSaveState ();
if ((prompt = strrchr (argv[0], '/')))
++prompt;
else
prompt = argv[0];
user = alias = NULL;
rlogin = (strncmp (prompt, "rlog", 4) == 0) ? '~' : _POSIX_VDISABLE;
autologin = -1;
while ((ch = getopt (argc, argv, "78DEKLS:X:ab:cde:fFk:l:n:rt:x")) != -1)
{
switch (ch)
{
case '8':
eight = 3; /* binary output and input */
break;
case '7':
eight = 0;
break;
case 'D':
{
/* sometimes we don't want a mangled display */
char *p;
if ((p = getenv ("DISPLAY")))
env_define ("DISPLAY", (unsigned char *) p);
break;
}
case 'E':
rlogin = escape = _POSIX_VDISABLE;
break;
case 'K':
/* autologin = 0; */
break;
case 'L':
eight |= 2; /* binary output only */
break;
case 'S':
{
#ifdef HAS_GETTOS
extern int tos;
if ((tos = parsetos (optarg, "tcp")) < 0)
fprintf (stderr, "%s%s%s%s\n",
prompt, ": Bad TOS argument '",
optarg, "; will try to use default TOS");
#else
fprintf (stderr,
"%s: Warning: -S ignored, no parsetos() support.\n",
prompt);
#endif
}
break;
case 'X':
#ifdef AUTHENTICATION
auth_disable_name (optarg);
#endif
break;
case 'a':
autologin = 1;
break;
case 'c':
skiprc = 1;
break;
case 'd':
debug = 1;
break;
case 'e':
set_escape_char (optarg);
break;
case 'f':
fprintf (stderr,
"%s: Warning: -f ignored, no Kerberos V5 support.\n",
prompt);
break;
case 'F':
fprintf (stderr,
"%s: Warning: -F ignored, no Kerberos V5 support.\n",
prompt);
break;
case 'k':
fprintf (stderr,
"%s: Warning: -k ignored, no Kerberos V4 support.\n",
prompt);
break;
case 'l':
autologin = -1;
user = optarg;
break;
case 'b':
alias = optarg;
break;
case 'n':
#if defined(TN3270) && defined(__unix__)
/* distinguish between "-n oasynch" and "-noasynch" */
if (argv[optind - 1][0] == '-' && argv[optind - 1][1]
== 'n' && argv[optind - 1][2] == 'o')
{
if (!strcmp (optarg, "oasynch"))
{
noasynchtty = 1;
noasynchnet = 1;
}
else if (!strcmp (optarg, "oasynchtty"))
noasynchtty = 1;
else if (!strcmp (optarg, "oasynchnet"))
noasynchnet = 1;
}
else
#endif /* defined(TN3270) && defined(__unix__) */
SetNetTrace (optarg);
break;
case 'r':
rlogin = '******';
break;
case 't':
#if defined(TN3270) && defined(__unix__)
transcom = tline;
strncpy (transcom, optarg, sizeof (tline));
#else
fprintf (stderr,
"%s: Warning: -t ignored, no TN3270 support.\n", prompt);
#endif
break;
case 'x':
fprintf (stderr,
"%s: Warning: -x ignored, no ENCRYPT support.\n", prompt);
break;
case '?':
default:
usage ();
/* NOTREACHED */
}
}
if (autologin == -1)
autologin = (rlogin == _POSIX_VDISABLE) ? 0 : 1;
argc -= optind;
argv += optind;
if (argc)
{
char *args[7], **argp = args;
if (argc > 2)
usage ();
*argp++ = prompt;
if (user)
{
*argp++ = "-l";
*argp++ = user;
}
if (alias)
{
*argp++ = "-b";
*argp++ = alias;
}
*argp++ = argv[0]; /* host */
if (argc > 1)
*argp++ = argv[1]; /* port */
*argp = 0;
if (sigsetjmp (toplevel, 1) != 0)
Exit (0);
if (tn (argp - args, args) == 1)
return (0);
else
return (1);
}
sigsetjmp (toplevel, 1);
for (;;)
{
#ifdef TN3270
if (shell_active)
shell_continue ();
else
#endif
command (1, 0, 0);
}
return 0;
}