qse/ase/lsp/prim_let.c

176 lines
4.3 KiB
C
Raw Normal View History

2005-09-19 12:04:00 +00:00
/*
2006-10-26 08:17:38 +00:00
* $Id: prim_let.c,v 1.7 2006-10-26 08:17:37 bacon Exp $
2005-09-19 12:04:00 +00:00
*/
2006-10-26 08:17:38 +00:00
#include <ase/lsp/lsp_i.h>
2005-09-19 12:04:00 +00:00
2006-10-24 04:22:40 +00:00
static ase_lsp_obj_t* __prim_let (
ase_lsp_t* lsp, ase_lsp_obj_t* args, int sequential)
2005-09-19 12:04:00 +00:00
{
2006-10-24 04:22:40 +00:00
ase_lsp_frame_t* frame;
ase_lsp_obj_t* assoc;
ase_lsp_obj_t* body;
ase_lsp_obj_t* value;
2005-09-19 12:04:00 +00:00
2006-10-24 04:22:40 +00:00
ASE_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, ASE_LSP_PRIM_MAX_ARG_COUNT);
2005-09-19 12:04:00 +00:00
// create a new frame
2006-10-26 08:17:38 +00:00
frame = ase_lsp_newframe (lsp);
if (frame == ASE_NULL)
{
lsp->errnum = ASE_LSP_ENOMEM;
2006-10-24 04:22:40 +00:00
return ASE_NULL;
2005-09-19 12:04:00 +00:00
}
//frame->link = lsp->mem->frame;
2006-10-26 08:17:38 +00:00
if (sequential)
{
2005-09-19 12:04:00 +00:00
frame->link = lsp->mem->frame;
lsp->mem->frame = frame;
}
2006-10-26 08:17:38 +00:00
else
{
2005-09-19 12:04:00 +00:00
frame->link = lsp->mem->brooding_frame;
lsp->mem->brooding_frame = frame;
}
2006-10-24 04:22:40 +00:00
assoc = ASE_LSP_CAR(args);
2005-09-19 12:04:00 +00:00
//while (assoc != lsp->mem->nil) {
2006-10-26 08:17:38 +00:00
while (ASE_LSP_TYPE(assoc) == ASE_LSP_OBJ_CONS)
{
2006-10-24 04:22:40 +00:00
ase_lsp_obj_t* ass = ASE_LSP_CAR(assoc);
2006-10-26 08:17:38 +00:00
if (ASE_LSP_TYPE(ass) == ASE_LSP_OBJ_CONS)
{
2006-10-24 04:22:40 +00:00
ase_lsp_obj_t* n = ASE_LSP_CAR(ass);
ase_lsp_obj_t* v = ASE_LSP_CDR(ass);
2006-10-26 08:17:38 +00:00
if (ASE_LSP_TYPE(n) != ASE_LSP_OBJ_SYM)
{
2006-10-24 04:22:40 +00:00
lsp->errnum = ASE_LSP_ERR_BAD_ARG; // must be a symbol
2005-09-19 12:04:00 +00:00
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
2006-10-26 08:17:38 +00:00
ase_lsp_freeframe (lsp, frame);
2006-10-24 04:22:40 +00:00
return ASE_NULL;
2005-09-19 12:04:00 +00:00
}
2006-10-26 08:17:38 +00:00
if (v != lsp->mem->nil)
{
if (ASE_LSP_CDR(v) != lsp->mem->nil)
{
2006-10-24 04:22:40 +00:00
lsp->errnum = ASE_LSP_ERR_TOO_MANY_ARGS; // must be a symbol
2005-09-19 12:04:00 +00:00
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
2006-10-26 08:17:38 +00:00
ase_lsp_freeframe (lsp, frame);
2006-10-24 04:22:40 +00:00
return ASE_NULL;
2005-09-19 12:04:00 +00:00
}
2006-10-26 08:17:38 +00:00
if ((v = ase_lsp_eval(lsp, ASE_LSP_CAR(v))) == ASE_NULL)
{
2005-09-19 12:04:00 +00:00
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
2006-10-26 08:17:38 +00:00
ase_lsp_freeframe (lsp, frame);
2006-10-24 04:22:40 +00:00
return ASE_NULL;
2005-09-19 12:04:00 +00:00
}
}
2006-10-26 08:17:38 +00:00
if (ase_lsp_lookupinframe (lsp, frame, n) != ASE_NULL)
{
2006-10-24 04:22:40 +00:00
lsp->errnum = ASE_LSP_ERR_DUP_FORMAL;
2005-09-19 12:04:00 +00:00
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
2006-10-26 08:17:38 +00:00
ase_lsp_freeframe (lsp, frame);
2006-10-24 04:22:40 +00:00
return ASE_NULL;
2005-09-19 12:04:00 +00:00
}
2006-10-26 08:17:38 +00:00
if (ase_lsp_insertvalueintoframe (lsp, frame, n, v) == ASE_NULL)
{
lsp->errnum = ASE_LSP_ENOMEM;
2005-09-19 12:04:00 +00:00
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
2006-10-26 08:17:38 +00:00
ase_lsp_freeframe (lsp, frame);
2006-10-24 04:22:40 +00:00
return ASE_NULL;
2005-09-19 12:04:00 +00:00
}
}
2006-10-26 08:17:38 +00:00
else if (ASE_LSP_TYPE(ass) == ASE_LSP_OBJ_SYM)
{
if (ase_lsp_lookupinframe (lsp, frame, ass) != ASE_NULL)
{
2006-10-24 04:22:40 +00:00
lsp->errnum = ASE_LSP_ERR_DUP_FORMAL;
2005-09-19 12:04:00 +00:00
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
2006-10-26 08:17:38 +00:00
ase_lsp_freeframe (lsp, frame);
2006-10-24 04:22:40 +00:00
return ASE_NULL;
2005-09-19 12:04:00 +00:00
}
2006-10-26 08:17:38 +00:00
if (ase_lsp_insertvalueintoframe (lsp, frame, ass, lsp->mem->nil) == ASE_NULL)
{
lsp->errnum = ASE_LSP_ENOMEM;
2005-09-19 12:04:00 +00:00
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
2006-10-26 08:17:38 +00:00
ase_lsp_freeframe (lsp, frame);
2006-10-24 04:22:40 +00:00
return ASE_NULL;
2005-09-19 12:04:00 +00:00
}
}
2006-10-26 08:17:38 +00:00
else
{
2006-10-24 04:22:40 +00:00
lsp->errnum = ASE_LSP_ERR_BAD_ARG;
2005-09-19 12:04:00 +00:00
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
2006-10-26 08:17:38 +00:00
ase_lsp_freeframe (lsp, frame);
2006-10-24 04:22:40 +00:00
return ASE_NULL;
2005-09-19 12:04:00 +00:00
}
2006-10-24 04:22:40 +00:00
assoc = ASE_LSP_CDR(assoc);
2005-09-19 12:04:00 +00:00
}
if (assoc != lsp->mem->nil) {
2006-10-24 04:22:40 +00:00
lsp->errnum = ASE_LSP_ERR_BAD_ARG;
2005-09-19 12:04:00 +00:00
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
2006-10-26 08:17:38 +00:00
ase_lsp_freeframe (lsp, frame);
2006-10-24 04:22:40 +00:00
return ASE_NULL;
2005-09-19 12:04:00 +00:00
}
// push the frame
if (!sequential) {
lsp->mem->brooding_frame = frame->link;
frame->link = lsp->mem->frame;
lsp->mem->frame = frame;
}
// evaluate forms in the body
value = lsp->mem->nil;
2006-10-24 04:22:40 +00:00
body = ASE_LSP_CDR(args);
2005-09-19 12:04:00 +00:00
while (body != lsp->mem->nil) {
2006-10-24 04:22:40 +00:00
value = ase_lsp_eval (lsp, ASE_LSP_CAR(body));
if (value == ASE_NULL) {
2005-09-19 12:04:00 +00:00
lsp->mem->frame = frame->link;
2006-10-26 08:17:38 +00:00
ase_lsp_freeframe (lsp, frame);
2006-10-24 04:22:40 +00:00
return ASE_NULL;
2005-09-19 12:04:00 +00:00
}
2006-10-24 04:22:40 +00:00
body = ASE_LSP_CDR(body);
2005-09-19 12:04:00 +00:00
}
// pop the frame
lsp->mem->frame = frame->link;
// destroy the frame
2006-10-26 08:17:38 +00:00
ase_lsp_freeframe (lsp, frame);
2005-09-19 12:04:00 +00:00
return value;
}
2006-10-24 04:22:40 +00:00
ase_lsp_obj_t* ase_lsp_prim_let (ase_lsp_t* lsp, ase_lsp_obj_t* args)
2005-09-19 12:04:00 +00:00
{
/*
* (defun x (x y)
* (let ((temp1 10) (temp2 20))
* (+ x y temp1 temp2)))
* (x 40 50)
* temp1
*/
return __prim_let (lsp, args, 0);
}
2006-10-24 04:22:40 +00:00
ase_lsp_obj_t* ase_lsp_prim_letx (ase_lsp_t* lsp, ase_lsp_obj_t* args)
2005-09-19 12:04:00 +00:00
{
return __prim_let (lsp, args, 1);
}