*** empty log message ***
This commit is contained in:
parent
42ebe4d93e
commit
dbc3c255e6
@ -1,6 +1,6 @@
|
|||||||
AC_PREREQ(2.59)
|
AC_PREREQ(2.53)
|
||||||
AC_INIT([xpkit], [deb-0.1.0])
|
AC_INIT([xpkit], [deb-0.1.0])
|
||||||
AC_REVISION([$Revision: 1.12 $])
|
AC_REVISION([$Revision: 1.13 $])
|
||||||
AC_CONFIG_HEADER([xp/config.h])
|
AC_CONFIG_HEADER([xp/config.h])
|
||||||
|
|
||||||
# Checks for programs.
|
# Checks for programs.
|
||||||
@ -35,5 +35,5 @@ AC_CHECK_FILE([/NextDeveloper],[AC_DEFINE([_POSIX_SOURCE],[],[_POSIX_SOURCE])])
|
|||||||
|
|
||||||
AC_CONFIG_FILES([
|
AC_CONFIG_FILES([
|
||||||
Makefile build/Makefile xp/Makefile
|
Makefile build/Makefile xp/Makefile
|
||||||
xp/c/Makefile xp/test/c/Makefile])
|
xp/c/Makefile xp/lisp/Makefile xp/test/c/Makefile])
|
||||||
AC_OUTPUT
|
AC_OUTPUT
|
||||||
|
103
ase/lsp/array.c
Normal file
103
ase/lsp/array.c
Normal file
@ -0,0 +1,103 @@
|
|||||||
|
/*
|
||||||
|
* $Id: array.c,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#include "array.h"
|
||||||
|
#include <stdlib.h>
|
||||||
|
#include <assert.h>
|
||||||
|
|
||||||
|
xp_lisp_array_t* xp_lisp_array_new (xp_size_t capacity)
|
||||||
|
{
|
||||||
|
xp_lisp_array_t* array;
|
||||||
|
|
||||||
|
assert (capacity > 0);
|
||||||
|
array = (xp_lisp_array_t*)malloc (sizeof(xp_lisp_array_t));
|
||||||
|
if (array == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
array->buffer = (void**)malloc (capacity + 1);
|
||||||
|
if (array->buffer == XP_NULL) {
|
||||||
|
free (array);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
array->size = 0;
|
||||||
|
array->capacity = capacity;
|
||||||
|
array->buffer[0] = XP_NULL;
|
||||||
|
return array;
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_array_free (xp_lisp_array_t* array)
|
||||||
|
{
|
||||||
|
while (array->size > 0)
|
||||||
|
free (array->buffer[--array->size]);
|
||||||
|
assert (array->size == 0);
|
||||||
|
|
||||||
|
free (array->buffer);
|
||||||
|
free (array);
|
||||||
|
}
|
||||||
|
|
||||||
|
int xp_lisp_array_add_item (xp_lisp_array_t* array, void* item)
|
||||||
|
{
|
||||||
|
if (array->size >= array->capacity) {
|
||||||
|
void* new_buffer = (void**)realloc (
|
||||||
|
array->buffer, array->capacity * 2 + 1);
|
||||||
|
if (new_buffer == XP_NULL) return -1;
|
||||||
|
array->buffer = new_buffer;
|
||||||
|
array->capacity = array->capacity * 2;
|
||||||
|
}
|
||||||
|
|
||||||
|
array->buffer[array->size++] = item;
|
||||||
|
array->buffer[array->size] = XP_NULL;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
int xp_lisp_array_insert (xp_lisp_array_t* array, xp_size_t index, void* value)
|
||||||
|
{
|
||||||
|
xp_size_t i;
|
||||||
|
|
||||||
|
if (index >= array->capacity) {
|
||||||
|
void* new_buffer = (void**)realloc (
|
||||||
|
array->buffer, array->capacity * 2 + 1);
|
||||||
|
if (new_buffer == XP_NULL) return -1;
|
||||||
|
array->buffer = new_buffer;
|
||||||
|
array->capacity = array->capacity * 2;
|
||||||
|
}
|
||||||
|
|
||||||
|
for (i = array->size; i > index; i--) {
|
||||||
|
array->buffer[i] = array->buffer[i - 1];
|
||||||
|
}
|
||||||
|
array->buffer[index] = value;
|
||||||
|
array->size = (index > array->size)? index + 1: array->size + 1;
|
||||||
|
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_array_delete (xp_lisp_array_t* array, xp_size_t index)
|
||||||
|
{
|
||||||
|
assert (index < array->size);
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_array_clear (xp_lisp_array_t* array)
|
||||||
|
{
|
||||||
|
while (array->size > 0)
|
||||||
|
free (array->buffer[--array->size]);
|
||||||
|
assert (array->size == 0);
|
||||||
|
array->buffer[0] = XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
void** xp_lisp_array_transfer (xp_lisp_array_t* array, xp_size_t capacity)
|
||||||
|
{
|
||||||
|
void** old_buffer, ** new_buffer;
|
||||||
|
|
||||||
|
new_buffer = (void**)malloc(capacity + 1);
|
||||||
|
if (new_buffer == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
old_buffer = array->buffer;
|
||||||
|
array->buffer = new_buffer;
|
||||||
|
array->size = 0;
|
||||||
|
array->capacity = capacity;
|
||||||
|
array->buffer[0] = XP_NULL;
|
||||||
|
|
||||||
|
return old_buffer;
|
||||||
|
}
|
34
ase/lsp/array.h
Normal file
34
ase/lsp/array.h
Normal file
@ -0,0 +1,34 @@
|
|||||||
|
/*
|
||||||
|
* $Id: array.h,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#ifndef _RBL_ARRAY_H_
|
||||||
|
#define _RBL_ARRAY_H_
|
||||||
|
|
||||||
|
#include <rb/types.h>
|
||||||
|
|
||||||
|
struct xp_lisp_array_t {
|
||||||
|
void** buffer;
|
||||||
|
xp_size_t size;
|
||||||
|
xp_size_t capacity;
|
||||||
|
};
|
||||||
|
|
||||||
|
typedef struct xp_lisp_array_t xp_lisp_array_t;
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
extern "C" {
|
||||||
|
#endif
|
||||||
|
|
||||||
|
xp_lisp_array_t* xp_lisp_array_new (xp_size_t capacity);
|
||||||
|
void xp_lisp_array_free (xp_lisp_array_t* array);
|
||||||
|
int xp_lisp_array_add_item (xp_lisp_array_t* array, void* item);
|
||||||
|
int xp_lisp_array_insert (xp_lisp_array_t* array, xp_size_t index, void* value);
|
||||||
|
void xp_lisp_array_delete (xp_lisp_array_t* array, xp_size_t index);
|
||||||
|
void xp_lisp_array_clear (xp_lisp_array_t* array);
|
||||||
|
void** xp_lisp_array_transfer (xp_lisp_array_t* array, xp_size_t capacity);
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#endif
|
82
ase/lsp/env.c
Normal file
82
ase/lsp/env.c
Normal file
@ -0,0 +1,82 @@
|
|||||||
|
/*
|
||||||
|
* $Id: env.c,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#include "environment.h"
|
||||||
|
#include <xp/c/stdlib.h>
|
||||||
|
|
||||||
|
xp_lisp_assoc_t* xp_lisp_assoc_new (xp_lisp_obj_t* name, xp_lisp_obj_t* value)
|
||||||
|
{
|
||||||
|
xp_lisp_assoc_t* assoc;
|
||||||
|
|
||||||
|
assoc = (xp_lisp_assoc_t*) xp_malloc (sizeof(xp_lisp_assoc_t));
|
||||||
|
if (assoc == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
assoc->name = name;
|
||||||
|
assoc->value = value;
|
||||||
|
assoc->link = XP_NULL;
|
||||||
|
|
||||||
|
return assoc;
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_assoc_free (xp_lisp_assoc_t* assoc)
|
||||||
|
{
|
||||||
|
xp_free (assoc);
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_frame_t* xp_lisp_frame_new (void)
|
||||||
|
{
|
||||||
|
xp_lisp_frame_t* frame;
|
||||||
|
|
||||||
|
frame = (xp_lisp_frame_t*) xp_malloc (sizeof(xp_lisp_frame_t));
|
||||||
|
if (frame == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
frame->assoc = XP_NULL;
|
||||||
|
frame->link = XP_NULL;
|
||||||
|
|
||||||
|
return frame;
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_frame_free (xp_lisp_frame_t* frame)
|
||||||
|
{
|
||||||
|
xp_lisp_assoc_t* assoc, * link;
|
||||||
|
|
||||||
|
// destroy the associations
|
||||||
|
assoc = frame->assoc;
|
||||||
|
while (assoc != XP_NULL) {
|
||||||
|
link = assoc->link;
|
||||||
|
xp_lisp_assoc_free (assoc);
|
||||||
|
assoc = link;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_free (frame);
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_assoc_t* xp_lisp_frame_lookup (xp_lisp_frame_t* frame, xp_lisp_obj_t* name)
|
||||||
|
{
|
||||||
|
xp_lisp_assoc_t* assoc;
|
||||||
|
|
||||||
|
xp_lisp_assert (RBL_TYPE(name) == RBL_OBJ_SYMBOL);
|
||||||
|
|
||||||
|
assoc = frame->assoc;
|
||||||
|
while (assoc != XP_NULL) {
|
||||||
|
if (name == assoc->name) return assoc;
|
||||||
|
assoc = assoc->link;
|
||||||
|
}
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_assoc_t* xp_lisp_frame_insert (
|
||||||
|
xp_lisp_frame_t* frame, xp_lisp_obj_t* name, xp_lisp_obj_t* value)
|
||||||
|
{
|
||||||
|
xp_lisp_assoc_t* assoc;
|
||||||
|
|
||||||
|
xp_lisp_assert (RBL_TYPE(name) == RBL_OBJ_SYMBOL);
|
||||||
|
|
||||||
|
assoc = xp_lisp_assoc_new (name, value);
|
||||||
|
if (assoc == XP_NULL) return XP_NULL;
|
||||||
|
assoc->link = frame->assoc;
|
||||||
|
frame->assoc = assoc;
|
||||||
|
return assoc;
|
||||||
|
}
|
||||||
|
|
42
ase/lsp/env.h
Normal file
42
ase/lsp/env.h
Normal file
@ -0,0 +1,42 @@
|
|||||||
|
/*
|
||||||
|
* $Id: env.h,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#ifndef _RBL_ENV_H_
|
||||||
|
#define _RBL_ENV_H_
|
||||||
|
|
||||||
|
#include "object.h"
|
||||||
|
|
||||||
|
struct xp_lisp_assoc_t
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* name; // xp_lisp_obj_symbol_t
|
||||||
|
xp_lisp_obj_t* value;
|
||||||
|
struct xp_lisp_assoc_t* link;
|
||||||
|
};
|
||||||
|
|
||||||
|
struct xp_lisp_frame_t
|
||||||
|
{
|
||||||
|
struct xp_lisp_assoc_t* assoc;
|
||||||
|
struct xp_lisp_frame_t* link;
|
||||||
|
};
|
||||||
|
|
||||||
|
typedef struct xp_lisp_assoc_t xp_lisp_assoc_t;
|
||||||
|
typedef struct xp_lisp_frame_t xp_lisp_frame_t;
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
extern "C" {
|
||||||
|
#endif
|
||||||
|
|
||||||
|
xp_lisp_assoc_t* xp_lisp_assoc_new (xp_lisp_obj_t* name, xp_lisp_obj_t* value);
|
||||||
|
void xp_lisp_assoc_free (xp_lisp_assoc_t* assoc);
|
||||||
|
|
||||||
|
xp_lisp_frame_t* xp_lisp_frame_new (void);
|
||||||
|
void xp_lisp_frame_free (xp_lisp_frame_t* frame);
|
||||||
|
xp_lisp_assoc_t* xp_lisp_frame_lookup (xp_lisp_frame_t* frame, xp_lisp_obj_t* name);
|
||||||
|
xp_lisp_assoc_t* xp_lisp_frame_insert (xp_lisp_frame_t* frame, xp_lisp_obj_t* name, xp_lisp_obj_t* value);
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#endif
|
275
ase/lsp/eval.c
Normal file
275
ase/lsp/eval.c
Normal file
@ -0,0 +1,275 @@
|
|||||||
|
/*
|
||||||
|
* $Id: eval.c,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#include "lsp.h"
|
||||||
|
#include "env.h"
|
||||||
|
#include "prim.h"
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
extern "C" {
|
||||||
|
#endif
|
||||||
|
|
||||||
|
static xp_lisp_obj_t* make_func (xp_lisp_t* lsp, xp_lisp_obj_t* cdr, int is_macro);
|
||||||
|
static xp_lisp_obj_t* eval_cons (xp_lisp_t* lsp, xp_lisp_obj_t* cons);
|
||||||
|
static xp_lisp_obj_t* apply (xp_lisp_t* lsp, xp_lisp_obj_t* func, xp_lisp_obj_t* actual);
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_eval (xp_lisp_t* lsp, xp_lisp_obj_t* obj)
|
||||||
|
{
|
||||||
|
lsp->error = RBL_ERR_NONE;
|
||||||
|
|
||||||
|
if (RBL_TYPE(obj) == RBL_OBJ_CONS)
|
||||||
|
return eval_cons (lsp, obj);
|
||||||
|
else if (RBL_TYPE(obj) == RBL_OBJ_SYMBOL) {
|
||||||
|
xp_lisp_assoc_t* assoc;
|
||||||
|
|
||||||
|
/*
|
||||||
|
if (obj == lsp->mem->lambda || obj == lsp->mem->macro) {
|
||||||
|
printf ("lambda or macro can't be used as a normal symbol\n");
|
||||||
|
lsp->error = RBL_ERR_BAD_SYMBOL;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
*/
|
||||||
|
|
||||||
|
if ((assoc = xp_lisp_lookup (lsp->mem, obj)) == XP_NULL) {
|
||||||
|
if (lsp->opt_undef_symbol) {
|
||||||
|
lsp->error = RBL_ERR_UNDEF_SYMBOL;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
return lsp->mem->nil;
|
||||||
|
}
|
||||||
|
|
||||||
|
obj = assoc->value;
|
||||||
|
}
|
||||||
|
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
|
||||||
|
static xp_lisp_obj_t* make_func (xp_lisp_t* lsp, xp_lisp_obj_t* cdr, int is_macro)
|
||||||
|
{
|
||||||
|
// TODO: lambda expression syntax check.
|
||||||
|
xp_lisp_obj_t* func, * formal, * body;
|
||||||
|
|
||||||
|
printf ("about to create a function or a macro ....\n");
|
||||||
|
|
||||||
|
if (cdr == lsp->mem->nil) {
|
||||||
|
lsp->error = RBL_ERR_TOO_FEW_ARGS;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
if (RBL_TYPE(cdr) != RBL_OBJ_CONS) {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
formal = RBL_CAR(cdr);
|
||||||
|
body = RBL_CDR(cdr);
|
||||||
|
|
||||||
|
if (body == lsp->mem->nil) {
|
||||||
|
lsp->error = RBL_ERR_EMPTY_BODY;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
func = (is_macro)?
|
||||||
|
xp_lisp_make_macro (lsp->mem, formal, body):
|
||||||
|
xp_lisp_make_func (lsp->mem, formal, body);
|
||||||
|
if (func == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
return func;
|
||||||
|
}
|
||||||
|
|
||||||
|
static xp_lisp_obj_t* eval_cons (xp_lisp_t* lsp, xp_lisp_obj_t* cons)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* car, * cdr;
|
||||||
|
|
||||||
|
xp_lisp_assert (RBL_TYPE(cons) == RBL_OBJ_CONS);
|
||||||
|
|
||||||
|
car = RBL_CAR(cons);
|
||||||
|
cdr = RBL_CDR(cons);
|
||||||
|
|
||||||
|
if (car == lsp->mem->lambda) {
|
||||||
|
return make_func (lsp, cdr, 0);
|
||||||
|
}
|
||||||
|
else if (car == lsp->mem->macro) {
|
||||||
|
return make_func (lsp, cdr, 1);
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(car) == RBL_OBJ_SYMBOL) {
|
||||||
|
xp_lisp_assoc_t* assoc;
|
||||||
|
|
||||||
|
if ((assoc = xp_lisp_lookup (lsp->mem, car)) != XP_NULL) {
|
||||||
|
xp_lisp_obj_t* func = assoc->value;
|
||||||
|
if (RBL_TYPE(func) == RBL_OBJ_FUNC ||
|
||||||
|
RBL_TYPE(func) == RBL_OBJ_MACRO) {
|
||||||
|
return apply (lsp, func, cdr);
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(func) == RBL_OBJ_PRIM) {
|
||||||
|
// primitive function
|
||||||
|
return RBL_PIMPL(func) (lsp, cdr);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
printf ("undefined function: ");
|
||||||
|
xp_lisp_print (lsp, car);
|
||||||
|
printf ("\n");
|
||||||
|
lsp->error = RBL_ERR_UNDEF_FUNC;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
//TODO: better error handling.
|
||||||
|
printf ("undefined function: ");
|
||||||
|
xp_lisp_print (lsp, car);
|
||||||
|
printf ("\n");
|
||||||
|
lsp->error = RBL_ERR_UNDEF_FUNC;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(car) == RBL_OBJ_FUNC ||
|
||||||
|
RBL_TYPE(car) == RBL_OBJ_MACRO) {
|
||||||
|
return apply (lsp, car, cdr);
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(car) == RBL_OBJ_CONS) {
|
||||||
|
if (RBL_CAR(car) == lsp->mem->lambda) {
|
||||||
|
xp_lisp_obj_t* func = make_func (lsp, RBL_CDR(car), 0);
|
||||||
|
if (func == XP_NULL) return XP_NULL;
|
||||||
|
return apply (lsp, func, cdr);
|
||||||
|
}
|
||||||
|
else if (RBL_CAR(car) == lsp->mem->macro) {
|
||||||
|
xp_lisp_obj_t* func = make_func (lsp, RBL_CDR(car), 1);
|
||||||
|
if (func == XP_NULL) return XP_NULL;
|
||||||
|
return apply (lsp, func, cdr);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
rb_printf (RBL_TEXT("bad function: "));
|
||||||
|
xp_lisp_print (lsp, car);
|
||||||
|
rb_printf (RBL_TEXT("\n"));
|
||||||
|
lsp->error = RBL_ERR_BAD_FUNC;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
static xp_lisp_obj_t* apply (xp_lisp_t* lsp, xp_lisp_obj_t* func, xp_lisp_obj_t* actual)
|
||||||
|
{
|
||||||
|
xp_lisp_frame_t* frame;
|
||||||
|
xp_lisp_obj_t* formal;
|
||||||
|
xp_lisp_obj_t* body;
|
||||||
|
xp_lisp_obj_t* value;
|
||||||
|
xp_lisp_mem_t* mem;
|
||||||
|
|
||||||
|
xp_lisp_assert (
|
||||||
|
RBL_TYPE(func) == RBL_OBJ_FUNC ||
|
||||||
|
RBL_TYPE(func) == RBL_OBJ_MACRO);
|
||||||
|
|
||||||
|
xp_lisp_assert (RBL_TYPE(RBL_CDR(func)) == RBL_OBJ_CONS);
|
||||||
|
|
||||||
|
mem = lsp->mem;
|
||||||
|
|
||||||
|
if (RBL_TYPE(func) == RBL_OBJ_MACRO) {
|
||||||
|
formal = RBL_MFORMAL (func);
|
||||||
|
body = RBL_MBODY (func);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
formal = RBL_FFORMAL (func);
|
||||||
|
body = RBL_FBODY (func);
|
||||||
|
}
|
||||||
|
|
||||||
|
// make a new frame.
|
||||||
|
frame = xp_lisp_frame_new ();
|
||||||
|
if (frame == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
// attach it to the brooding frame list to
|
||||||
|
// make them not to be garbage collected.
|
||||||
|
frame->link = mem->brooding_frame;
|
||||||
|
mem->brooding_frame = frame;
|
||||||
|
|
||||||
|
// evaluate arguments and push them into the frame.
|
||||||
|
while (formal != mem->nil) {
|
||||||
|
if (actual == mem->nil) {
|
||||||
|
lsp->error = RBL_ERR_TOO_FEW_ARGS;
|
||||||
|
mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
value = RBL_CAR(actual);
|
||||||
|
if (RBL_TYPE(func) != RBL_OBJ_MACRO) {
|
||||||
|
// macro doesn't evaluate actual arguments.
|
||||||
|
value = xp_lisp_eval (lsp, value);
|
||||||
|
if (value == XP_NULL) {
|
||||||
|
mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
if (xp_lisp_frame_lookup (frame, RBL_CAR(formal)) != XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_DUP_FORMAL;
|
||||||
|
mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
if (xp_lisp_frame_insert (frame, RBL_CAR(formal), value) == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
actual = RBL_CDR(actual);
|
||||||
|
formal = RBL_CDR(formal);
|
||||||
|
}
|
||||||
|
|
||||||
|
if (RBL_TYPE(actual) == RBL_OBJ_CONS) {
|
||||||
|
lsp->error = RBL_ERR_TOO_MANY_ARGS;
|
||||||
|
mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
else if (actual != mem->nil) {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG;
|
||||||
|
mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
// push the frame
|
||||||
|
mem->brooding_frame = frame->link;
|
||||||
|
frame->link = mem->frame;
|
||||||
|
mem->frame = frame;
|
||||||
|
|
||||||
|
// do the evaluation of the body
|
||||||
|
value = mem->nil;
|
||||||
|
while (body != mem->nil) {
|
||||||
|
value = xp_lisp_eval(lsp, RBL_CAR(body));
|
||||||
|
if (value == XP_NULL) {
|
||||||
|
mem->frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
body = RBL_CDR(body);
|
||||||
|
}
|
||||||
|
|
||||||
|
// pop the frame.
|
||||||
|
mem->frame = frame->link;
|
||||||
|
|
||||||
|
// destroy the frame.
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
|
||||||
|
//if (RBL_CAR(func) == mem->macro) {
|
||||||
|
if (RBL_TYPE(func) == RBL_OBJ_MACRO) {
|
||||||
|
value = xp_lisp_eval(lsp, value);
|
||||||
|
if (value == XP_NULL) return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
return value;
|
||||||
|
}
|
||||||
|
|
71
ase/lsp/lisp.c
Normal file
71
ase/lsp/lisp.c
Normal file
@ -0,0 +1,71 @@
|
|||||||
|
/*
|
||||||
|
* $Id: lisp.c,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#include "lsp.h"
|
||||||
|
#include <stdlib.h>
|
||||||
|
|
||||||
|
xp_lisp_t* xp_lisp_new (xp_size_t mem_ubound, xp_size_t mem_ubound_inc)
|
||||||
|
{
|
||||||
|
xp_lisp_t* lsp;
|
||||||
|
|
||||||
|
lsp = (xp_lisp_t*)malloc(sizeof(xp_lisp_t));
|
||||||
|
if (lsp == XP_NULL) return lsp;
|
||||||
|
|
||||||
|
lsp->token = xp_lisp_token_new (256);
|
||||||
|
if (lsp->token == XP_NULL) {
|
||||||
|
free (lsp);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
lsp->error = RBL_ERR_NONE;
|
||||||
|
//lsp->opt_undef_symbol = 1;
|
||||||
|
lsp->opt_undef_symbol = 0;
|
||||||
|
|
||||||
|
lsp->curc = RBL_CHAR_END;
|
||||||
|
lsp->creader = XP_NULL;
|
||||||
|
lsp->creader_extra = XP_NULL;
|
||||||
|
lsp->creader_just_set = 0;
|
||||||
|
lsp->outstream = stdout;
|
||||||
|
|
||||||
|
lsp->mem = xp_lisp_mem_new (mem_ubound, mem_ubound_inc);
|
||||||
|
if (lsp->mem == XP_NULL) {
|
||||||
|
xp_lisp_token_free (lsp->token);
|
||||||
|
free (lsp);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
if (xp_lisp_add_prims (lsp->mem) == -1) {
|
||||||
|
xp_lisp_mem_free (lsp->mem);
|
||||||
|
xp_lisp_token_free (lsp->token);
|
||||||
|
free (lsp);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
return lsp;
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_free (xp_lisp_t* lsp)
|
||||||
|
{
|
||||||
|
xp_lisp_assert (lsp != XP_NULL);
|
||||||
|
|
||||||
|
xp_lisp_mem_free (lsp->mem);
|
||||||
|
xp_lisp_token_free (lsp->token);
|
||||||
|
free (lsp);
|
||||||
|
}
|
||||||
|
|
||||||
|
int xp_lisp_error (xp_lisp_t* lsp, xp_lisp_char* buf, xp_size_t size)
|
||||||
|
{
|
||||||
|
if (buf != XP_NULL || size == 0) return lsp->error;
|
||||||
|
|
||||||
|
// TODO:...
|
||||||
|
/*
|
||||||
|
switch (lsp->error) {
|
||||||
|
|
||||||
|
default:
|
||||||
|
xp_lisp_copy_string (buf, size, "unknown error");
|
||||||
|
}
|
||||||
|
*/
|
||||||
|
|
||||||
|
return lsp->error;
|
||||||
|
}
|
87
ase/lsp/lisp.h
Normal file
87
ase/lsp/lisp.h
Normal file
@ -0,0 +1,87 @@
|
|||||||
|
/*
|
||||||
|
* $Id: lisp.h,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#ifndef _RBL_LISP_H_
|
||||||
|
#define _RBL_LISP_H_
|
||||||
|
|
||||||
|
#include <xp/lisp/types.h>
|
||||||
|
#include <xp/lisp/token.h>
|
||||||
|
#include <xp/lisp/object.h>
|
||||||
|
#include <xp/lisp/memory.h>
|
||||||
|
|
||||||
|
// NOTICE: the function of xp_lisp_creader_t must return -1 on error
|
||||||
|
// and 0 on success. the first argument must be set to
|
||||||
|
// RBL_END_CHAR at the end of input.
|
||||||
|
typedef int (*xp_lisp_creader_t) (xp_lisp_cint*, void*);
|
||||||
|
|
||||||
|
#define RBL_ERR(lsp) ((lsp)->error)
|
||||||
|
#define RBL_ERR_NONE 0
|
||||||
|
#define RBL_ERR_ABORT 1
|
||||||
|
#define RBL_ERR_END 2
|
||||||
|
#define RBL_ERR_MEM 3
|
||||||
|
#define RBL_ERR_READ 4
|
||||||
|
#define RBL_ERR_SYNTAX 5
|
||||||
|
#define RBL_ERR_BAD_ARG 6
|
||||||
|
#define RBL_ERR_WRONG_ARG 7
|
||||||
|
#define RBL_ERR_TOO_FEW_ARGS 8
|
||||||
|
#define RBL_ERR_TOO_MANY_ARGS 9
|
||||||
|
#define RBL_ERR_UNDEF_FUNC 10
|
||||||
|
#define RBL_ERR_BAD_FUNC 11
|
||||||
|
#define RBL_ERR_DUP_FORMAL 12
|
||||||
|
#define RBL_ERR_BAD_SYMBOL 13
|
||||||
|
#define RBL_ERR_UNDEF_SYMBOL 14
|
||||||
|
#define RBL_ERR_EMPTY_BODY 15
|
||||||
|
#define RBL_ERR_BAD_VALUE 16
|
||||||
|
|
||||||
|
struct xp_lisp_t
|
||||||
|
{
|
||||||
|
/* error number */
|
||||||
|
int error;
|
||||||
|
int opt_undef_symbol;
|
||||||
|
|
||||||
|
/* for read */
|
||||||
|
xp_lisp_cint curc;
|
||||||
|
xp_lisp_creader_t creader;
|
||||||
|
void* creader_extra;
|
||||||
|
int creader_just_set;
|
||||||
|
xp_lisp_token_t* token;
|
||||||
|
|
||||||
|
/* for eval */
|
||||||
|
xp_size_t max_eval_depth; // TODO:....
|
||||||
|
xp_size_t eval_depth;
|
||||||
|
|
||||||
|
/* for print */
|
||||||
|
FILE* outstream;
|
||||||
|
|
||||||
|
/* memory manager */
|
||||||
|
xp_lisp_mem_t* mem;
|
||||||
|
};
|
||||||
|
|
||||||
|
typedef struct xp_lisp_t xp_lisp_t;
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
extern "C" {
|
||||||
|
#endif
|
||||||
|
|
||||||
|
/* lsp.c */
|
||||||
|
xp_lisp_t* xp_lisp_new (xp_size_t mem_ubound, xp_size_t mem_ubound_inc);
|
||||||
|
void xp_lisp_free (xp_lisp_t* lsp);
|
||||||
|
int xp_lisp_error (xp_lisp_t* lsp, xp_lisp_char* buf, xp_size_t size);
|
||||||
|
|
||||||
|
/* read.c */
|
||||||
|
// TODO: move xp_lisp_set_creader to lsp.c
|
||||||
|
void xp_lisp_set_creader (xp_lisp_t* lsp, xp_lisp_creader_t func, void* extra);
|
||||||
|
xp_lisp_obj_t* xp_lisp_read (xp_lisp_t* lsp);
|
||||||
|
|
||||||
|
/* eval.c */
|
||||||
|
xp_lisp_obj_t* xp_lisp_eval (xp_lisp_t* lsp, xp_lisp_obj_t* obj);
|
||||||
|
|
||||||
|
/* print.c */
|
||||||
|
void xp_lisp_print (xp_lisp_t* lsp, xp_lisp_obj_t* obj);
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#endif
|
20
ase/lsp/makefile.in
Normal file
20
ase/lsp/makefile.in
Normal file
@ -0,0 +1,20 @@
|
|||||||
|
SRCS = env.c token.c mem.c lsp.c prim.c read.c eval.c print.c array.c
|
||||||
|
OBJS = $(SRCS:.c=.o)
|
||||||
|
OUT = libxplisp.a
|
||||||
|
|
||||||
|
CC = @CC@
|
||||||
|
RANLIB = @RANLIB@
|
||||||
|
CFLAGS = @CFLAGS@ -I@abs_top_builddir@
|
||||||
|
LDFLAGS = @LDFLAGS@
|
||||||
|
LIBS = @LIBS@
|
||||||
|
|
||||||
|
all: $(OBJS)
|
||||||
|
ar cr $(OUT) $(OBJS)
|
||||||
|
ranlib $(OUT)
|
||||||
|
|
||||||
|
clean:
|
||||||
|
rm -rf $(OBJS) $(OUT) *.o
|
||||||
|
|
||||||
|
.SUFFIXES: .c .o
|
||||||
|
.c.o:
|
||||||
|
$(CC) $(CFLAGS) -c $<
|
658
ase/lsp/memory.c
Normal file
658
ase/lsp/memory.c
Normal file
@ -0,0 +1,658 @@
|
|||||||
|
/*
|
||||||
|
* $Id: memory.c,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#include <xp/lisp/memory.h>
|
||||||
|
#include <xp/lisp/primitive.h>
|
||||||
|
#include <xp/c/stdlib.h>
|
||||||
|
|
||||||
|
xp_lisp_mem_t* xp_lisp_mem_new (xp_size_t ubound, xp_size_t ubound_inc)
|
||||||
|
{
|
||||||
|
xp_lisp_mem_t* mem;
|
||||||
|
xp_size_t i;
|
||||||
|
|
||||||
|
// allocate memory
|
||||||
|
mem = (xp_lisp_mem_t*)xp_malloc (sizeof(xp_lisp_mem_t));
|
||||||
|
if (mem == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
// create a new root environment frame
|
||||||
|
mem->frame = xp_lisp_frame_new ();
|
||||||
|
if (mem->frame == XP_NULL) {
|
||||||
|
xp_free (mem);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
mem->root_frame = mem->frame;
|
||||||
|
mem->brooding_frame = XP_NULL;
|
||||||
|
|
||||||
|
// create an array to hold temporary objects
|
||||||
|
mem->temp_array = xp_lisp_array_new (512);
|
||||||
|
if (mem->temp_array == XP_NULL) {
|
||||||
|
xp_lisp_frame_free (mem->frame);
|
||||||
|
xp_free (mem);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
// initialize object allocation list
|
||||||
|
mem->ubound = ubound;
|
||||||
|
mem->ubound_inc = ubound_inc;
|
||||||
|
mem->count = 0;
|
||||||
|
for (i = 0; i < RBL_TYPE_COUNT; i++) {
|
||||||
|
mem->used[i] = XP_NULL;
|
||||||
|
mem->free[i] = XP_NULL;
|
||||||
|
}
|
||||||
|
mem->locked = XP_NULL;
|
||||||
|
|
||||||
|
// when "ubound" is too small, the garbage collection can
|
||||||
|
// be performed while making the common objects.
|
||||||
|
mem->nil = XP_NULL;
|
||||||
|
mem->t = XP_NULL;
|
||||||
|
mem->quote = XP_NULL;
|
||||||
|
mem->lambda = XP_NULL;
|
||||||
|
mem->macro = XP_NULL;
|
||||||
|
|
||||||
|
// initialize common object pointers
|
||||||
|
mem->nil = xp_lisp_make_nil (mem);
|
||||||
|
mem->t = xp_lisp_make_true (mem);
|
||||||
|
mem->quote = xp_lisp_make_symbol (mem, RBL_TEXT("quote"), 5);
|
||||||
|
mem->lambda = xp_lisp_make_symbol (mem, RBL_TEXT("lambda"), 6);
|
||||||
|
mem->macro = xp_lisp_make_symbol (mem, RBL_TEXT("macro"), 5);
|
||||||
|
|
||||||
|
if (mem->nil == XP_NULL ||
|
||||||
|
mem->t == XP_NULL ||
|
||||||
|
mem->quote == XP_NULL ||
|
||||||
|
mem->lambda == XP_NULL ||
|
||||||
|
mem->macro == XP_NULL) {
|
||||||
|
xp_lisp_dispose_all (mem);
|
||||||
|
xp_lisp_array_free (mem->temp_array);
|
||||||
|
xp_lisp_frame_free (mem->frame);
|
||||||
|
xp_free (mem);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
return mem;
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_mem_free (xp_lisp_mem_t* mem)
|
||||||
|
{
|
||||||
|
xp_lisp_assert (mem != XP_NULL);
|
||||||
|
|
||||||
|
// dispose of the allocated objects
|
||||||
|
xp_lisp_dispose_all (mem);
|
||||||
|
|
||||||
|
// dispose of the temporary object arrays
|
||||||
|
xp_lisp_array_free (mem->temp_array);
|
||||||
|
|
||||||
|
// dispose of environment frames
|
||||||
|
xp_lisp_frame_free (mem->frame);
|
||||||
|
|
||||||
|
// free the memory
|
||||||
|
xp_free (mem);
|
||||||
|
}
|
||||||
|
|
||||||
|
static int xp_lisp_add_prim (
|
||||||
|
xp_lisp_mem_t* mem, const xp_lisp_char* name, xp_size_t len, xp_lisp_pimpl_t prim)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* n, * p;
|
||||||
|
|
||||||
|
n = xp_lisp_make_symbol (mem, name, len);
|
||||||
|
if (n == XP_NULL) return -1;
|
||||||
|
|
||||||
|
xp_lisp_lock (n);
|
||||||
|
|
||||||
|
p = xp_lisp_make_prim (mem, prim);
|
||||||
|
if (p == XP_NULL) return -1;
|
||||||
|
|
||||||
|
xp_lisp_unlock (n);
|
||||||
|
|
||||||
|
if (xp_lisp_set (mem, n, p) == XP_NULL) return -1;
|
||||||
|
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
int xp_lisp_add_prims (xp_lisp_mem_t* mem)
|
||||||
|
{
|
||||||
|
|
||||||
|
#define ADD_PRIM(mem,name,len,prim) \
|
||||||
|
if (xp_lisp_add_prim(mem,name,len,prim) == -1) return -1;
|
||||||
|
|
||||||
|
ADD_PRIM (mem, RB_TEXT("abort"), 5, xp_lisp_prim_abort);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("eval"), 4, xp_lisp_prim_eval);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("prog1"), 5, xp_lisp_prim_prog1);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("progn"), 5, xp_lisp_prim_progn);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("gc"), 2, xp_lisp_prim_gc);
|
||||||
|
|
||||||
|
ADD_PRIM (mem, RB_TEXT("cond"), 4, xp_lisp_prim_cond);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("if"), 2, xp_lisp_prim_if);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("while"), 5, xp_lisp_prim_while);
|
||||||
|
|
||||||
|
ADD_PRIM (mem, RB_TEXT("car"), 3, xp_lisp_prim_car);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("cdr"), 3, xp_lisp_prim_cdr);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("cons"), 4, xp_lisp_prim_cons);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("set"), 3, xp_lisp_prim_set);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("setq"), 4, xp_lisp_prim_setq);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("quote"), 5, xp_lisp_prim_quote);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("defun"), 5, xp_lisp_prim_defun);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("demac"), 5, xp_lisp_prim_demac);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("let"), 3, xp_lisp_prim_let);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("let*"), 4, xp_lisp_prim_letx);
|
||||||
|
|
||||||
|
ADD_PRIM (mem, RB_TEXT("+"), 1, xp_lisp_prim_plus);
|
||||||
|
ADD_PRIM (mem, RB_TEXT(">"), 1, xp_lisp_prim_gt);
|
||||||
|
ADD_PRIM (mem, RB_TEXT("<"), 1, xp_lisp_prim_lt);
|
||||||
|
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_allocate (xp_lisp_mem_t* mem, int type, xp_size_t size)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* obj;
|
||||||
|
|
||||||
|
if (mem->count >= mem->ubound) xp_lisp_garbage_collect (mem);
|
||||||
|
if (mem->count >= mem->ubound) {
|
||||||
|
mem->ubound += mem->ubound_inc;
|
||||||
|
if (mem->count >= mem->ubound) return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
obj = (xp_lisp_obj_t*)xp_malloc (size);
|
||||||
|
if (obj == XP_NULL) {
|
||||||
|
xp_lisp_garbage_collect (mem);
|
||||||
|
|
||||||
|
obj = (xp_lisp_obj_t*)xp_malloc (size);
|
||||||
|
if (obj == XP_NULL) return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
RBL_TYPE(obj) = type;
|
||||||
|
RBL_SIZE(obj) = size;
|
||||||
|
RBL_MARK(obj) = 0;
|
||||||
|
RBL_LOCK(obj) = 0;
|
||||||
|
|
||||||
|
// insert the object at the head of the used list
|
||||||
|
RBL_LINK(obj) = mem->used[type];
|
||||||
|
mem->used[type] = obj;
|
||||||
|
mem->count++;
|
||||||
|
RB_DEBUG1 (RB_TEXT("mem->count: %u\n"), mem->count);
|
||||||
|
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_dispose (xp_lisp_mem_t* mem, xp_lisp_obj_t* prev, xp_lisp_obj_t* obj)
|
||||||
|
{
|
||||||
|
xp_lisp_assert (mem != XP_NULL);
|
||||||
|
xp_lisp_assert (obj != XP_NULL);
|
||||||
|
xp_lisp_assert (mem->count > 0);
|
||||||
|
|
||||||
|
// TODO: push the object to the free list for more
|
||||||
|
// efficient memory management
|
||||||
|
|
||||||
|
if (prev == XP_NULL)
|
||||||
|
mem->used[RBL_TYPE(obj)] = RBL_LINK(obj);
|
||||||
|
else RBL_LINK(prev) = RBL_LINK(obj);
|
||||||
|
|
||||||
|
mem->count--;
|
||||||
|
RB_DEBUG1 (RB_TEXT("mem->count: %u\n"), mem->count);
|
||||||
|
|
||||||
|
xp_free (obj);
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_dispose_all (xp_lisp_mem_t* mem)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* obj, * next;
|
||||||
|
xp_size_t i;
|
||||||
|
|
||||||
|
for (i = 0; i < RBL_TYPE_COUNT; i++) {
|
||||||
|
obj = mem->used[i];
|
||||||
|
|
||||||
|
while (obj != XP_NULL) {
|
||||||
|
next = RBL_LINK(obj);
|
||||||
|
xp_lisp_dispose (mem, XP_NULL, obj);
|
||||||
|
obj = next;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
static void xp_lisp_mark_obj (xp_lisp_obj_t* obj)
|
||||||
|
{
|
||||||
|
xp_lisp_assert (obj != XP_NULL);
|
||||||
|
|
||||||
|
// TODO:....
|
||||||
|
// can it be recursive?
|
||||||
|
if (RBL_MARK(obj) != 0) return;
|
||||||
|
|
||||||
|
RBL_MARK(obj) = 1;
|
||||||
|
|
||||||
|
if (RBL_TYPE(obj) == RBL_OBJ_CONS) {
|
||||||
|
xp_lisp_mark_obj (RBL_CAR(obj));
|
||||||
|
xp_lisp_mark_obj (RBL_CDR(obj));
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(obj) == RBL_OBJ_FUNC) {
|
||||||
|
xp_lisp_mark_obj (RBL_FFORMAL(obj));
|
||||||
|
xp_lisp_mark_obj (RBL_FBODY(obj));
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(obj) == RBL_OBJ_MACRO) {
|
||||||
|
xp_lisp_mark_obj (RBL_MFORMAL(obj));
|
||||||
|
xp_lisp_mark_obj (RBL_MBODY(obj));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
/*
|
||||||
|
* xp_lisp_lock and xp_lisp_unlock_all are just called by xp_lisp_read.
|
||||||
|
*/
|
||||||
|
void xp_lisp_lock (xp_lisp_obj_t* obj)
|
||||||
|
{
|
||||||
|
xp_lisp_assert (obj != XP_NULL);
|
||||||
|
RBL_LOCK(obj) = 1;
|
||||||
|
//RBL_MARK(obj) = 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_unlock (xp_lisp_obj_t* obj)
|
||||||
|
{
|
||||||
|
xp_lisp_assert (obj != XP_NULL);
|
||||||
|
RBL_LOCK(obj) = 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_unlock_all (xp_lisp_obj_t* obj)
|
||||||
|
{
|
||||||
|
xp_lisp_assert (obj != XP_NULL);
|
||||||
|
|
||||||
|
RBL_LOCK(obj) = 0;
|
||||||
|
|
||||||
|
if (RBL_TYPE(obj) == RBL_OBJ_CONS) {
|
||||||
|
xp_lisp_unlock_all (RBL_CAR(obj));
|
||||||
|
xp_lisp_unlock_all (RBL_CDR(obj));
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(obj) == RBL_OBJ_FUNC) {
|
||||||
|
xp_lisp_unlock_all (RBL_FFORMAL(obj));
|
||||||
|
xp_lisp_unlock_all (RBL_FBODY(obj));
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(obj) == RBL_OBJ_MACRO) {
|
||||||
|
xp_lisp_unlock_all (RBL_MFORMAL(obj));
|
||||||
|
xp_lisp_unlock_all (RBL_MBODY(obj));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
static void xp_lisp_mark (xp_lisp_mem_t* mem)
|
||||||
|
{
|
||||||
|
xp_lisp_frame_t* frame;
|
||||||
|
xp_lisp_assoc_t* assoc;
|
||||||
|
xp_lisp_array_t* array;
|
||||||
|
xp_size_t i;
|
||||||
|
|
||||||
|
RB_DEBUG0 (RB_TEXT("marking environment frames\n"));
|
||||||
|
// mark objects in the environment frames
|
||||||
|
frame = mem->frame;
|
||||||
|
while (frame != XP_NULL) {
|
||||||
|
assoc = frame->assoc;
|
||||||
|
while (assoc != XP_NULL) {
|
||||||
|
xp_lisp_mark_obj (assoc->name);
|
||||||
|
xp_lisp_mark_obj (assoc->value);
|
||||||
|
assoc = assoc->link;
|
||||||
|
}
|
||||||
|
|
||||||
|
frame = frame->link;
|
||||||
|
}
|
||||||
|
|
||||||
|
RB_DEBUG0 (RB_TEXT("marking interim frames\n"));
|
||||||
|
|
||||||
|
// mark objects in the interim frames
|
||||||
|
frame = mem->brooding_frame;
|
||||||
|
while (frame != XP_NULL) {
|
||||||
|
|
||||||
|
assoc = frame->assoc;
|
||||||
|
while (assoc != XP_NULL) {
|
||||||
|
xp_lisp_mark_obj (assoc->name);
|
||||||
|
xp_lisp_mark_obj (assoc->value);
|
||||||
|
assoc = assoc->link;
|
||||||
|
}
|
||||||
|
|
||||||
|
frame = frame->link;
|
||||||
|
}
|
||||||
|
|
||||||
|
/*
|
||||||
|
RB_DEBUG0 (RB_TEXT("marking the locked object\n"));
|
||||||
|
if (mem->locked != XP_NULL) xp_lisp_mark_obj (mem->locked);
|
||||||
|
*/
|
||||||
|
|
||||||
|
RB_DEBUG0 (RB_TEXT("marking termporary objects\n"));
|
||||||
|
array = mem->temp_array;
|
||||||
|
for (i = 0; i < array->size; i++) {
|
||||||
|
xp_lisp_mark_obj (array->buffer[i]);
|
||||||
|
}
|
||||||
|
|
||||||
|
RB_DEBUG0 (RB_TEXT("marking builtin objects\n"));
|
||||||
|
// mark common objects
|
||||||
|
if (mem->t != XP_NULL) xp_lisp_mark_obj (mem->t);
|
||||||
|
if (mem->nil != XP_NULL) xp_lisp_mark_obj (mem->nil);
|
||||||
|
if (mem->quote != XP_NULL) xp_lisp_mark_obj (mem->quote);
|
||||||
|
if (mem->lambda != XP_NULL) xp_lisp_mark_obj (mem->lambda);
|
||||||
|
if (mem->macro != XP_NULL) xp_lisp_mark_obj (mem->macro);
|
||||||
|
}
|
||||||
|
|
||||||
|
static void xp_lisp_sweep (xp_lisp_mem_t* mem)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* obj, * prev, * next;
|
||||||
|
xp_size_t i;
|
||||||
|
|
||||||
|
// scan all the allocated objects and get rid of unused objects
|
||||||
|
for (i = 0; i < RBL_TYPE_COUNT; i++) {
|
||||||
|
//for (i = RBL_TYPE_COUNT; i > 0; /*i--*/) {
|
||||||
|
prev = XP_NULL;
|
||||||
|
obj = mem->used[i];
|
||||||
|
//obj = mem->used[--i];
|
||||||
|
|
||||||
|
RB_DEBUG1 (RB_TEXT("sweeping objects of type: %u\n"), i);
|
||||||
|
|
||||||
|
while (obj != XP_NULL) {
|
||||||
|
next = RBL_LINK(obj);
|
||||||
|
|
||||||
|
if (RBL_LOCK(obj) == 0 && RBL_MARK(obj) == 0) {
|
||||||
|
// dispose of unused objects
|
||||||
|
xp_lisp_dispose (mem, prev, obj);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
// unmark the object in use
|
||||||
|
RBL_MARK(obj) = 0;
|
||||||
|
prev = obj;
|
||||||
|
}
|
||||||
|
|
||||||
|
obj = next;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_garbage_collect (xp_lisp_mem_t* mem)
|
||||||
|
{
|
||||||
|
xp_lisp_mark (mem);
|
||||||
|
xp_lisp_sweep (mem);
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_nil (xp_lisp_mem_t* mem)
|
||||||
|
{
|
||||||
|
if (mem->nil != XP_NULL) return mem->nil;
|
||||||
|
mem->nil = xp_lisp_allocate (mem, RBL_OBJ_NIL, sizeof(xp_lisp_obj_nil_t));
|
||||||
|
return mem->nil;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_true (xp_lisp_mem_t* mem)
|
||||||
|
{
|
||||||
|
if (mem->t != XP_NULL) return mem->t;
|
||||||
|
mem->t = xp_lisp_allocate (mem, RBL_OBJ_TRUE, sizeof(xp_lisp_obj_true_t));
|
||||||
|
return mem->t;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_int (xp_lisp_mem_t* mem, xp_lisp_int value)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* obj;
|
||||||
|
|
||||||
|
obj = xp_lisp_allocate (mem, RBL_OBJ_INT, sizeof(xp_lisp_obj_int_t));
|
||||||
|
if (obj == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
RBL_IVALUE(obj) = value;
|
||||||
|
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_float (xp_lisp_mem_t* mem, xp_lisp_float value)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* obj;
|
||||||
|
|
||||||
|
obj = xp_lisp_allocate (mem, RBL_OBJ_FLOAT, sizeof(xp_lisp_obj_float_t));
|
||||||
|
if (obj == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
RBL_FVALUE(obj) = value;
|
||||||
|
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_symbol (xp_lisp_mem_t* mem, const xp_lisp_char* str, xp_size_t len)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* obj;
|
||||||
|
|
||||||
|
// look for a sysmbol with the given name
|
||||||
|
obj = mem->used[RBL_OBJ_SYMBOL];
|
||||||
|
while (obj != XP_NULL) {
|
||||||
|
// if there is a symbol with the same name, it is just used.
|
||||||
|
if (xp_lisp_comp_symbol2 (obj, str, len) == 0) return obj;
|
||||||
|
obj = RBL_LINK(obj);
|
||||||
|
}
|
||||||
|
|
||||||
|
// no such symbol found. create a new one
|
||||||
|
obj = xp_lisp_allocate (mem, RBL_OBJ_SYMBOL,
|
||||||
|
sizeof(xp_lisp_obj_symbol_t) + (len + 1) * sizeof(xp_lisp_char));
|
||||||
|
if (obj == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
// fill in the symbol buffer
|
||||||
|
xp_lisp_copy_string2 (RBL_SYMVALUE(obj), str, len);
|
||||||
|
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_string (xp_lisp_mem_t* mem, const xp_lisp_char* str, xp_size_t len)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* obj;
|
||||||
|
|
||||||
|
// allocate memory for the string
|
||||||
|
obj = xp_lisp_allocate (mem, RBL_OBJ_STRING,
|
||||||
|
sizeof(xp_lisp_obj_string_t) + (len + 1) * sizeof(xp_lisp_char));
|
||||||
|
if (obj == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
// fill in the string buffer
|
||||||
|
xp_lisp_copy_string2 (RBL_STRVALUE(obj), str, len);
|
||||||
|
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_cons (xp_lisp_mem_t* mem, xp_lisp_obj_t* car, xp_lisp_obj_t* cdr)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* obj;
|
||||||
|
|
||||||
|
obj = xp_lisp_allocate (mem, RBL_OBJ_CONS, sizeof(xp_lisp_obj_cons_t));
|
||||||
|
if (obj == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
RBL_CAR(obj) = car;
|
||||||
|
RBL_CDR(obj) = cdr;
|
||||||
|
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_func (xp_lisp_mem_t* mem, xp_lisp_obj_t* formal, xp_lisp_obj_t* body)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* obj;
|
||||||
|
|
||||||
|
obj = xp_lisp_allocate (mem, RBL_OBJ_FUNC, sizeof(xp_lisp_obj_func_t));
|
||||||
|
if (obj == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
RBL_FFORMAL(obj) = formal;
|
||||||
|
RBL_FBODY(obj) = body;
|
||||||
|
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_macro (xp_lisp_mem_t* mem, xp_lisp_obj_t* formal, xp_lisp_obj_t* body)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* obj;
|
||||||
|
|
||||||
|
obj = xp_lisp_allocate (mem, RBL_OBJ_MACRO, sizeof(xp_lisp_obj_macro_t));
|
||||||
|
if (obj == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
RBL_MFORMAL(obj) = formal;
|
||||||
|
RBL_MBODY(obj) = body;
|
||||||
|
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_prim (xp_lisp_mem_t* mem, void* impl)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* obj;
|
||||||
|
|
||||||
|
obj = xp_lisp_allocate (mem, RBL_OBJ_PRIM, sizeof(xp_lisp_obj_prim_t));
|
||||||
|
if (obj == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
RBL_PIMPL(obj) = impl;
|
||||||
|
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_assoc_t* xp_lisp_lookup (xp_lisp_mem_t* mem, xp_lisp_obj_t* name)
|
||||||
|
{
|
||||||
|
xp_lisp_frame_t* frame;
|
||||||
|
xp_lisp_assoc_t* assoc;
|
||||||
|
|
||||||
|
xp_lisp_assert (RBL_TYPE(name) == RBL_OBJ_SYMBOL);
|
||||||
|
|
||||||
|
frame = mem->frame;
|
||||||
|
|
||||||
|
while (frame != XP_NULL) {
|
||||||
|
assoc = xp_lisp_frame_lookup (frame, name);
|
||||||
|
if (assoc != XP_NULL) return assoc;
|
||||||
|
frame = frame->link;
|
||||||
|
}
|
||||||
|
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_assoc_t* xp_lisp_set (xp_lisp_mem_t* mem, xp_lisp_obj_t* name, xp_lisp_obj_t* value)
|
||||||
|
{
|
||||||
|
xp_lisp_assoc_t* assoc;
|
||||||
|
|
||||||
|
assoc = xp_lisp_lookup (mem, name);
|
||||||
|
if (assoc == XP_NULL) {
|
||||||
|
assoc = xp_lisp_frame_insert (mem->root_frame, name, value);
|
||||||
|
if (assoc == XP_NULL) return XP_NULL;
|
||||||
|
}
|
||||||
|
else assoc->value = value;
|
||||||
|
|
||||||
|
return assoc;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_size_t xp_lisp_cons_len (xp_lisp_mem_t* mem, xp_lisp_obj_t* obj)
|
||||||
|
{
|
||||||
|
xp_size_t count;
|
||||||
|
|
||||||
|
xp_lisp_assert (obj == mem->nil || RBL_TYPE(obj) == RBL_OBJ_CONS);
|
||||||
|
|
||||||
|
count = 0;
|
||||||
|
//while (obj != mem->nil) {
|
||||||
|
while (RBL_TYPE(obj) == RBL_OBJ_CONS) {
|
||||||
|
count++;
|
||||||
|
obj = RBL_CDR(obj);
|
||||||
|
}
|
||||||
|
|
||||||
|
return count;
|
||||||
|
}
|
||||||
|
|
||||||
|
int xp_lisp_probe_args (xp_lisp_mem_t* mem, xp_lisp_obj_t* obj, xp_size_t* len)
|
||||||
|
{
|
||||||
|
xp_size_t count = 0;
|
||||||
|
|
||||||
|
while (RBL_TYPE(obj) == RBL_OBJ_CONS) {
|
||||||
|
count++;
|
||||||
|
obj = RBL_CDR(obj);
|
||||||
|
}
|
||||||
|
|
||||||
|
if (obj != mem->nil) return -1;
|
||||||
|
|
||||||
|
*len = count;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
int xp_lisp_comp_symbol (xp_lisp_obj_t* obj, const xp_lisp_char* str)
|
||||||
|
{
|
||||||
|
xp_lisp_char* p;
|
||||||
|
xp_size_t index, length;
|
||||||
|
|
||||||
|
xp_lisp_assert (RBL_TYPE(obj) == RBL_OBJ_SYMBOL);
|
||||||
|
|
||||||
|
index = 0;
|
||||||
|
length = RBL_SYMLEN(obj);
|
||||||
|
|
||||||
|
p = RBL_SYMVALUE(obj);
|
||||||
|
while (index < length) {
|
||||||
|
if (*p > *str) return 1;
|
||||||
|
if (*p < *str) return -1;
|
||||||
|
index++; p++; str++;
|
||||||
|
}
|
||||||
|
|
||||||
|
return (*str == RBL_CHAR('\0'))? 0: -1;
|
||||||
|
}
|
||||||
|
|
||||||
|
int xp_lisp_comp_symbol2 (xp_lisp_obj_t* obj, const xp_lisp_char* str, xp_size_t len)
|
||||||
|
{
|
||||||
|
xp_lisp_char* p;
|
||||||
|
xp_size_t index, length;
|
||||||
|
|
||||||
|
xp_lisp_assert (RBL_TYPE(obj) == RBL_OBJ_SYMBOL);
|
||||||
|
|
||||||
|
index = 0;
|
||||||
|
length = RBL_SYMLEN(obj);
|
||||||
|
p = RBL_SYMVALUE(obj);
|
||||||
|
|
||||||
|
while (index < length && index < len) {
|
||||||
|
if (*p > *str) return 1;
|
||||||
|
if (*p < *str) return -1;
|
||||||
|
index++; p++; str++;
|
||||||
|
}
|
||||||
|
|
||||||
|
return (length < len)? -1:
|
||||||
|
(length > len)? 1: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
int xp_lisp_comp_string (xp_lisp_obj_t* obj, const xp_lisp_char* str)
|
||||||
|
{
|
||||||
|
xp_lisp_char* p;
|
||||||
|
xp_size_t index, length;
|
||||||
|
|
||||||
|
xp_lisp_assert (RBL_TYPE(obj) == RBL_OBJ_STRING);
|
||||||
|
|
||||||
|
index = 0;
|
||||||
|
length = RBL_STRLEN(obj);
|
||||||
|
|
||||||
|
p = RBL_STRVALUE(obj);
|
||||||
|
while (index < length) {
|
||||||
|
if (*p > *str) return 1;
|
||||||
|
if (*p < *str) return -1;
|
||||||
|
index++; p++; str++;
|
||||||
|
}
|
||||||
|
|
||||||
|
return (*str == RBL_CHAR('\0'))? 0: -1;
|
||||||
|
}
|
||||||
|
|
||||||
|
int xp_lisp_comp_string2 (xp_lisp_obj_t* obj, const xp_lisp_char* str, xp_size_t len)
|
||||||
|
{
|
||||||
|
xp_lisp_char* p;
|
||||||
|
xp_size_t index, length;
|
||||||
|
|
||||||
|
xp_lisp_assert (RBL_TYPE(obj) == RBL_OBJ_STRING);
|
||||||
|
|
||||||
|
index = 0;
|
||||||
|
length = RBL_STRLEN(obj);
|
||||||
|
p = RBL_STRVALUE(obj);
|
||||||
|
|
||||||
|
while (index < length && index < len) {
|
||||||
|
if (*p > *str) return 1;
|
||||||
|
if (*p < *str) return -1;
|
||||||
|
index++; p++; str++;
|
||||||
|
}
|
||||||
|
|
||||||
|
return (length < len)? -1:
|
||||||
|
(length > len)? 1: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_copy_string (xp_lisp_char* dst, const xp_lisp_char* str)
|
||||||
|
{
|
||||||
|
// the buffer pointed by dst should be big enough to hold str
|
||||||
|
while (*str != RBL_CHAR('\0')) *dst++ = *str++;
|
||||||
|
*dst = RBL_CHAR('\0');
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_copy_string2 (xp_lisp_char* dst, const xp_lisp_char* str, xp_size_t len)
|
||||||
|
{
|
||||||
|
// the buffer pointed by dst should be big enough to hold str
|
||||||
|
while (len > 0) {
|
||||||
|
*dst++ = *str++;
|
||||||
|
len--;
|
||||||
|
}
|
||||||
|
*dst = RBL_CHAR('\0');
|
||||||
|
}
|
||||||
|
|
100
ase/lsp/memory.h
Normal file
100
ase/lsp/memory.h
Normal file
@ -0,0 +1,100 @@
|
|||||||
|
/*
|
||||||
|
* $Id: memory.h,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#ifndef _RBL_MEM_H_
|
||||||
|
#define _RBL_MEM_H_
|
||||||
|
|
||||||
|
#include "obj.h"
|
||||||
|
#include "env.h"
|
||||||
|
#include "array.h"
|
||||||
|
|
||||||
|
struct xp_lisp_mem_t
|
||||||
|
{
|
||||||
|
/*
|
||||||
|
* object allocation list
|
||||||
|
*/
|
||||||
|
xp_size_t ubound; // upper bounds of the maximum number of objects
|
||||||
|
xp_size_t ubound_inc; // increment of the upper bounds
|
||||||
|
xp_size_t count; // the number of objects currently allocated
|
||||||
|
xp_lisp_obj_t* used[RBL_TYPE_COUNT];
|
||||||
|
xp_lisp_obj_t* free[RBL_TYPE_COUNT];
|
||||||
|
xp_lisp_obj_t* locked;
|
||||||
|
|
||||||
|
/*
|
||||||
|
* commonly accessed objects
|
||||||
|
*/
|
||||||
|
xp_lisp_obj_t* nil; // xp_lisp_obj_nil_t
|
||||||
|
xp_lisp_obj_t* t; // xp_lisp_obj_true_t
|
||||||
|
xp_lisp_obj_t* quote; // xp_lisp_obj_symbol_t
|
||||||
|
xp_lisp_obj_t* lambda; // xp_lisp_obj_symbol_t
|
||||||
|
xp_lisp_obj_t* macro; // xp_lisp_obj_symbol_t
|
||||||
|
|
||||||
|
/*
|
||||||
|
* run-time environment frame
|
||||||
|
*/
|
||||||
|
xp_lisp_frame_t* frame;
|
||||||
|
// pointer to a global-level frame
|
||||||
|
xp_lisp_frame_t* root_frame;
|
||||||
|
// pointer to an interim frame not yet added to "frame"
|
||||||
|
xp_lisp_frame_t* brooding_frame;
|
||||||
|
|
||||||
|
/*
|
||||||
|
* temporary objects
|
||||||
|
*/
|
||||||
|
xp_lisp_array_t* temp_array;
|
||||||
|
};
|
||||||
|
|
||||||
|
typedef struct xp_lisp_mem_t xp_lisp_mem_t;
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
extern "C" {
|
||||||
|
#endif
|
||||||
|
|
||||||
|
xp_lisp_mem_t* xp_lisp_mem_new (xp_size_t ubound, xp_size_t ubound_inc);
|
||||||
|
void xp_lisp_mem_free (xp_lisp_mem_t* mem);
|
||||||
|
|
||||||
|
int xp_lisp_add_prims (xp_lisp_mem_t* mem);
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_allocate (xp_lisp_mem_t* mem, int type, xp_size_t size);
|
||||||
|
void xp_lisp_dispose (xp_lisp_mem_t* mem, xp_lisp_obj_t* prev, xp_lisp_obj_t* obj);
|
||||||
|
void xp_lisp_dispose_all (xp_lisp_mem_t* mem);
|
||||||
|
void xp_lisp_garbage_collect (xp_lisp_mem_t* mem);
|
||||||
|
|
||||||
|
void xp_lisp_lock (xp_lisp_obj_t* obj);
|
||||||
|
void xp_lisp_unlock (xp_lisp_obj_t* obj);
|
||||||
|
void xp_lisp_unlock_all (xp_lisp_obj_t* obj);
|
||||||
|
|
||||||
|
// object creation of standard types
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_nil (xp_lisp_mem_t* mem);
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_true (xp_lisp_mem_t* mem);
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_int (xp_lisp_mem_t* mem, xp_lisp_int value);
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_float (xp_lisp_mem_t* mem, xp_lisp_float value);
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_symbol (xp_lisp_mem_t* mem, const xp_lisp_char* str, xp_size_t len);
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_string (xp_lisp_mem_t* mem, const xp_lisp_char* str, xp_size_t len);
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_cons (xp_lisp_mem_t* mem, xp_lisp_obj_t* car, xp_lisp_obj_t* cdr);
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_func (xp_lisp_mem_t* mem, xp_lisp_obj_t* formal, xp_lisp_obj_t* body);
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_macro (xp_lisp_mem_t* mem, xp_lisp_obj_t* formal, xp_lisp_obj_t* body);
|
||||||
|
xp_lisp_obj_t* xp_lisp_make_prim (xp_lisp_mem_t* mem, void* impl);
|
||||||
|
|
||||||
|
// frame lookup
|
||||||
|
xp_lisp_assoc_t* xp_lisp_lookup (xp_lisp_mem_t* mem, xp_lisp_obj_t* name);
|
||||||
|
xp_lisp_assoc_t* xp_lisp_set (xp_lisp_mem_t* mem, xp_lisp_obj_t* name, xp_lisp_obj_t* value);
|
||||||
|
|
||||||
|
// cons operations
|
||||||
|
xp_size_t xp_lisp_cons_len (xp_lisp_mem_t* mem, xp_lisp_obj_t* obj);
|
||||||
|
int xp_lisp_probe_args (xp_lisp_mem_t* mem, xp_lisp_obj_t* obj, xp_size_t* len);
|
||||||
|
|
||||||
|
// symbol and string operations
|
||||||
|
int xp_lisp_comp_symbol (xp_lisp_obj_t* obj, const xp_lisp_char* str);
|
||||||
|
int xp_lisp_comp_symbol2 (xp_lisp_obj_t* obj, const xp_lisp_char* str, xp_size_t len);
|
||||||
|
int xp_lisp_comp_string (xp_lisp_obj_t* obj, const xp_lisp_char* str);
|
||||||
|
int xp_lisp_comp_string2 (xp_lisp_obj_t* obj, const xp_lisp_char* str, xp_size_t len);
|
||||||
|
void xp_lisp_copy_string (xp_lisp_char* dst, const xp_lisp_char* str);
|
||||||
|
void xp_lisp_copy_string2 (xp_lisp_char* dst, const xp_lisp_char* str, xp_size_t len);
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#endif
|
151
ase/lsp/object.h
Normal file
151
ase/lsp/object.h
Normal file
@ -0,0 +1,151 @@
|
|||||||
|
/*
|
||||||
|
* $Id: object.h,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#ifndef _RBL_OBJECT_H_
|
||||||
|
#define _RBL_OBJECT_H_
|
||||||
|
|
||||||
|
#include "types.h"
|
||||||
|
|
||||||
|
// object types
|
||||||
|
enum
|
||||||
|
{
|
||||||
|
RBL_OBJ_NIL = 0,
|
||||||
|
RBL_OBJ_TRUE,
|
||||||
|
RBL_OBJ_INT,
|
||||||
|
RBL_OBJ_FLOAT,
|
||||||
|
RBL_OBJ_SYMBOL,
|
||||||
|
RBL_OBJ_STRING,
|
||||||
|
RBL_OBJ_CONS,
|
||||||
|
RBL_OBJ_FUNC,
|
||||||
|
RBL_OBJ_MACRO,
|
||||||
|
RBL_OBJ_PRIM,
|
||||||
|
|
||||||
|
RBL_TYPE_COUNT // the number of lisp object types
|
||||||
|
};
|
||||||
|
|
||||||
|
#define RBL_OBJ_HEADER \
|
||||||
|
rb_uint32 type: 24; \
|
||||||
|
rb_uint32 mark: 4; \
|
||||||
|
rb_uint32 lock: 4; \
|
||||||
|
xp_size_t size; \
|
||||||
|
struct xp_lisp_obj_t* link
|
||||||
|
|
||||||
|
struct xp_lisp_obj_t
|
||||||
|
{
|
||||||
|
RBL_OBJ_HEADER;
|
||||||
|
};
|
||||||
|
|
||||||
|
struct xp_lisp_obj_nil_t
|
||||||
|
{
|
||||||
|
RBL_OBJ_HEADER;
|
||||||
|
};
|
||||||
|
|
||||||
|
struct xp_lisp_obj_true_t
|
||||||
|
{
|
||||||
|
RBL_OBJ_HEADER;
|
||||||
|
};
|
||||||
|
|
||||||
|
struct xp_lisp_obj_int_t
|
||||||
|
{
|
||||||
|
RBL_OBJ_HEADER;
|
||||||
|
xp_lisp_int value;
|
||||||
|
};
|
||||||
|
|
||||||
|
struct xp_lisp_obj_float_t
|
||||||
|
{
|
||||||
|
RBL_OBJ_HEADER;
|
||||||
|
xp_lisp_float value;
|
||||||
|
};
|
||||||
|
|
||||||
|
struct xp_lisp_obj_symbol_t
|
||||||
|
{
|
||||||
|
RBL_OBJ_HEADER;
|
||||||
|
#ifdef __BORLANDC__
|
||||||
|
#else
|
||||||
|
xp_lisp_char buffer[0];
|
||||||
|
#endif
|
||||||
|
};
|
||||||
|
|
||||||
|
struct xp_lisp_obj_string_t
|
||||||
|
{
|
||||||
|
RBL_OBJ_HEADER;
|
||||||
|
#ifdef __BORLANDC__
|
||||||
|
#else
|
||||||
|
xp_lisp_char buffer[0];
|
||||||
|
#endif
|
||||||
|
};
|
||||||
|
|
||||||
|
struct xp_lisp_obj_cons_t
|
||||||
|
{
|
||||||
|
RBL_OBJ_HEADER;
|
||||||
|
struct xp_lisp_obj_t* car;
|
||||||
|
struct xp_lisp_obj_t* cdr;
|
||||||
|
};
|
||||||
|
|
||||||
|
struct xp_lisp_obj_func_t
|
||||||
|
{
|
||||||
|
RBL_OBJ_HEADER;
|
||||||
|
struct xp_lisp_obj_t* formal;
|
||||||
|
struct xp_lisp_obj_t* body;
|
||||||
|
};
|
||||||
|
|
||||||
|
struct xp_lisp_obj_macro_t
|
||||||
|
{
|
||||||
|
RBL_OBJ_HEADER;
|
||||||
|
struct xp_lisp_obj_t* formal;
|
||||||
|
struct xp_lisp_obj_t* body;
|
||||||
|
};
|
||||||
|
|
||||||
|
struct xp_lisp_obj_prim_t
|
||||||
|
{
|
||||||
|
RBL_OBJ_HEADER;
|
||||||
|
void* impl; // xp_lisp_prim_t
|
||||||
|
};
|
||||||
|
|
||||||
|
typedef struct xp_lisp_obj_t xp_lisp_obj_t;
|
||||||
|
typedef struct xp_lisp_obj_nil_t xp_lisp_obj_nil_t;
|
||||||
|
typedef struct xp_lisp_obj_true_t xp_lisp_obj_true_t;
|
||||||
|
typedef struct xp_lisp_obj_int_t xp_lisp_obj_int_t;
|
||||||
|
typedef struct xp_lisp_obj_float_t xp_lisp_obj_float_t;
|
||||||
|
typedef struct xp_lisp_obj_symbol_t xp_lisp_obj_symbol_t;
|
||||||
|
typedef struct xp_lisp_obj_string_t xp_lisp_obj_string_t;
|
||||||
|
typedef struct xp_lisp_obj_cons_t xp_lisp_obj_cons_t;
|
||||||
|
typedef struct xp_lisp_obj_func_t xp_lisp_obj_func_t;
|
||||||
|
typedef struct xp_lisp_obj_macro_t xp_lisp_obj_macro_t;
|
||||||
|
typedef struct xp_lisp_obj_prim_t xp_lisp_obj_prim_t;
|
||||||
|
|
||||||
|
// header access
|
||||||
|
#define RBL_TYPE(x) (((xp_lisp_obj_t*)x)->type)
|
||||||
|
#define RBL_SIZE(x) (((xp_lisp_obj_t*)x)->size)
|
||||||
|
#define RBL_MARK(x) (((xp_lisp_obj_t*)x)->mark)
|
||||||
|
#define RBL_LOCK(x) (((xp_lisp_obj_t*)x)->lock)
|
||||||
|
#define RBL_LINK(x) (((xp_lisp_obj_t*)x)->link)
|
||||||
|
|
||||||
|
// value access
|
||||||
|
#define RBL_IVALUE(x) (((xp_lisp_obj_int_t*)x)->value)
|
||||||
|
#define RBL_FVALUE(x) (((xp_lisp_obj_float_t*)x)->value)
|
||||||
|
|
||||||
|
#ifdef __BORLANDC__
|
||||||
|
#define RBL_SYMVALUE(x) ((xp_lisp_char*)(((xp_lisp_obj_symbol_t*)x) + 1))
|
||||||
|
#else
|
||||||
|
#define RBL_SYMVALUE(x) (((xp_lisp_obj_symbol_t*)x)->buffer)
|
||||||
|
#endif
|
||||||
|
#define RBL_SYMLEN(x) ((((xp_lisp_obj_symbol_t*)x)->size - sizeof(xp_lisp_obj_t)) / sizeof(xp_lisp_char) - 1)
|
||||||
|
|
||||||
|
#ifdef __BORLANDC__
|
||||||
|
#define RBL_STRVALUE(x) ((xp_lisp_char*)(((xp_lisp_obj_string_t*)x) + 1))
|
||||||
|
#else
|
||||||
|
#define RBL_STRVALUE(x) (((xp_lisp_obj_string_t*)x)->buffer)
|
||||||
|
#endif
|
||||||
|
#define RBL_STRLEN(x) ((((xp_lisp_obj_string_t*)x)->size - sizeof(xp_lisp_obj_t)) / sizeof(xp_lisp_char) - 1)
|
||||||
|
|
||||||
|
#define RBL_CAR(x) (((xp_lisp_obj_cons_t*)x)->car)
|
||||||
|
#define RBL_CDR(x) (((xp_lisp_obj_cons_t*)x)->cdr)
|
||||||
|
#define RBL_FFORMAL(x) (((xp_lisp_obj_func_t*)x)->formal)
|
||||||
|
#define RBL_FBODY(x) (((xp_lisp_obj_func_t*)x)->body)
|
||||||
|
#define RBL_MFORMAL(x) (((xp_lisp_obj_macro_t*)x)->formal)
|
||||||
|
#define RBL_MBODY(x) (((xp_lisp_obj_macro_t*)x)->body)
|
||||||
|
#define RBL_PIMPL(x) ((xp_lisp_pimpl_t)(((xp_lisp_obj_prim_t*)x)->impl))
|
||||||
|
|
||||||
|
#endif
|
686
ase/lsp/primitive.c
Normal file
686
ase/lsp/primitive.c
Normal file
@ -0,0 +1,686 @@
|
|||||||
|
/*
|
||||||
|
* $Id: primitive.c,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#include "lisp.h"
|
||||||
|
#include "memory.h"
|
||||||
|
#include "primitive.h"
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_abort (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 0, 0);
|
||||||
|
lsp->error = RBL_ERR_ABORT;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_eval (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* tmp;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
|
||||||
|
xp_lisp_assert (RBL_TYPE(args) == RBL_OBJ_CONS);
|
||||||
|
|
||||||
|
tmp = xp_lisp_eval (lsp, RBL_CAR(args));
|
||||||
|
if (tmp == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
tmp = xp_lisp_eval (lsp, tmp);
|
||||||
|
if (tmp == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
return tmp;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_prog1 (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* res = XP_NULL, * tmp;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 1, RBL_PRIM_MAX_ARG_COUNT);
|
||||||
|
|
||||||
|
//while (args != lsp->mem->nil) {
|
||||||
|
while (RBL_TYPE(args) == RBL_OBJ_CONS) {
|
||||||
|
|
||||||
|
tmp = xp_lisp_eval (lsp, RBL_CAR(args));
|
||||||
|
if (tmp == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
if (res == XP_NULL) {
|
||||||
|
/*
|
||||||
|
xp_lisp_array_t* ta = lsp->mem->temp_array;
|
||||||
|
xp_lisp_array_insert (ta, ta->size, tmp);
|
||||||
|
*/
|
||||||
|
res = tmp;
|
||||||
|
}
|
||||||
|
args = RBL_CDR(args);
|
||||||
|
}
|
||||||
|
|
||||||
|
return res;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_progn (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* res, * tmp;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 1, RBL_PRIM_MAX_ARG_COUNT);
|
||||||
|
|
||||||
|
res = lsp->mem->nil;
|
||||||
|
//while (args != lsp->mem->nil) {
|
||||||
|
while (RBL_TYPE(args) == RBL_OBJ_CONS) {
|
||||||
|
|
||||||
|
tmp = xp_lisp_eval (lsp, RBL_CAR(args));
|
||||||
|
if (tmp == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
res = tmp;
|
||||||
|
args = RBL_CDR(args);
|
||||||
|
}
|
||||||
|
|
||||||
|
return res;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_gc (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 0, 0);
|
||||||
|
xp_lisp_garbage_collect (lsp->mem);
|
||||||
|
return lsp->mem->nil;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_cond (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
/*
|
||||||
|
* (cond
|
||||||
|
* (condition1 result1)
|
||||||
|
* (consition2 result2)
|
||||||
|
* ...
|
||||||
|
* (t resultN))
|
||||||
|
*/
|
||||||
|
|
||||||
|
xp_lisp_obj_t* tmp, * ret;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 0, RBL_PRIM_MAX_ARG_COUNT);
|
||||||
|
|
||||||
|
while (RBL_TYPE(args) == RBL_OBJ_CONS) {
|
||||||
|
if (RBL_TYPE(RBL_CAR(args)) != RBL_OBJ_CONS) {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
tmp = xp_lisp_eval (lsp, RBL_CAR(RBL_CAR(args)));
|
||||||
|
if (tmp == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
if (tmp != lsp->mem->nil) {
|
||||||
|
tmp = RBL_CDR(RBL_CAR(args));
|
||||||
|
ret = lsp->mem->nil;
|
||||||
|
while (RBL_TYPE(tmp) == RBL_OBJ_CONS) {
|
||||||
|
ret = xp_lisp_eval (lsp, RBL_CAR(tmp));
|
||||||
|
if (ret == XP_NULL) return XP_NULL;
|
||||||
|
tmp = RBL_CDR(tmp);
|
||||||
|
}
|
||||||
|
if (tmp != lsp->mem->nil) {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
return ret;
|
||||||
|
}
|
||||||
|
|
||||||
|
args = RBL_CDR(args);
|
||||||
|
}
|
||||||
|
|
||||||
|
return lsp->mem->nil;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_if (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* tmp;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 2, RBL_PRIM_MAX_ARG_COUNT);
|
||||||
|
xp_lisp_assert (RBL_TYPE(args) == RBL_OBJ_CONS);
|
||||||
|
|
||||||
|
tmp = xp_lisp_eval (lsp, RBL_CAR(args));
|
||||||
|
if (tmp == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
if (tmp != lsp->mem->nil) {
|
||||||
|
tmp = xp_lisp_eval (lsp, RBL_CAR(RBL_CDR(args)));
|
||||||
|
if (tmp == XP_NULL) return XP_NULL;
|
||||||
|
return tmp;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
xp_lisp_obj_t* res = lsp->mem->nil;
|
||||||
|
|
||||||
|
tmp = RBL_CDR(RBL_CDR(args));
|
||||||
|
|
||||||
|
while (RBL_TYPE(tmp) == RBL_OBJ_CONS) {
|
||||||
|
res = xp_lisp_eval (lsp, RBL_CAR(tmp));
|
||||||
|
if (res == XP_NULL) return XP_NULL;
|
||||||
|
tmp = RBL_CDR(tmp);
|
||||||
|
}
|
||||||
|
if (tmp != lsp->mem->nil) {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
return res;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_while (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
/*
|
||||||
|
* (setq a 1)
|
||||||
|
* (while (< a 100) (setq a (+ a 1)))
|
||||||
|
*/
|
||||||
|
|
||||||
|
xp_lisp_obj_t* tmp;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 1, RBL_PRIM_MAX_ARG_COUNT);
|
||||||
|
xp_lisp_assert (RBL_TYPE(args) == RBL_OBJ_CONS);
|
||||||
|
|
||||||
|
for (;;) {
|
||||||
|
tmp = xp_lisp_eval (lsp, RBL_CAR(args));
|
||||||
|
if (tmp == XP_NULL) return XP_NULL;
|
||||||
|
if (tmp == lsp->mem->nil) break;
|
||||||
|
|
||||||
|
tmp = RBL_CDR(args);
|
||||||
|
while (RBL_TYPE(tmp) == RBL_OBJ_CONS) {
|
||||||
|
if (xp_lisp_eval (lsp, RBL_CAR(tmp)) == XP_NULL) return XP_NULL;
|
||||||
|
tmp = RBL_CDR(tmp);
|
||||||
|
}
|
||||||
|
if (tmp != lsp->mem->nil) {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return lsp->mem->nil;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_car (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* tmp;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
|
||||||
|
xp_lisp_assert (RBL_TYPE(args) == RBL_OBJ_CONS);
|
||||||
|
|
||||||
|
tmp = xp_lisp_eval (lsp, RBL_CAR(args));
|
||||||
|
if (tmp == XP_NULL) return XP_NULL;
|
||||||
|
if (tmp == lsp->mem->nil) return lsp->mem->nil;
|
||||||
|
|
||||||
|
if (RBL_TYPE(tmp) != RBL_OBJ_CONS) {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
return RBL_CAR(tmp);
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_cdr (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* tmp;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
|
||||||
|
xp_lisp_assert (RBL_TYPE(args) == RBL_OBJ_CONS);
|
||||||
|
|
||||||
|
tmp = xp_lisp_eval (lsp, RBL_CAR(args));
|
||||||
|
if (tmp == XP_NULL) return XP_NULL;
|
||||||
|
if (tmp == lsp->mem->nil) return lsp->mem->nil;
|
||||||
|
|
||||||
|
if (RBL_TYPE(tmp) != RBL_OBJ_CONS) {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
return RBL_CDR(tmp);
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_cons (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* car, * cdr, * cons;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
|
||||||
|
xp_lisp_assert (RBL_TYPE(args) == RBL_OBJ_CONS);
|
||||||
|
|
||||||
|
car = xp_lisp_eval (lsp, RBL_CAR(args));
|
||||||
|
if (car == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
cdr = xp_lisp_eval (lsp, RBL_CAR(RBL_CDR(args)));
|
||||||
|
if (cdr == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
cons = xp_lisp_make_cons (lsp->mem, car, cdr);
|
||||||
|
if (cons == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
return cons;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_set (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* p1, * p2;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
|
||||||
|
xp_lisp_assert (RBL_TYPE(args) == RBL_OBJ_CONS);
|
||||||
|
|
||||||
|
p1 = xp_lisp_eval (lsp, RBL_CAR(args));
|
||||||
|
if (p1 == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
if (RBL_TYPE(p1) != RBL_OBJ_SYMBOL) {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
p2 = xp_lisp_eval (lsp, RBL_CAR(RBL_CDR(args)));
|
||||||
|
if (p2 == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
if (xp_lisp_set (lsp->mem, p1, p2) == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
return p2;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_setq (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* p = args, * p1, * p2 = lsp->mem->nil;
|
||||||
|
|
||||||
|
while (p != lsp->mem->nil) {
|
||||||
|
xp_lisp_assert (RBL_TYPE(p) == RBL_OBJ_CONS);
|
||||||
|
|
||||||
|
p1 = RBL_CAR(p);
|
||||||
|
if (RBL_TYPE(p1) != RBL_OBJ_SYMBOL) {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
if (RBL_TYPE(RBL_CDR(p)) != RBL_OBJ_CONS) {
|
||||||
|
lsp->error = RBL_ERR_TOO_FEW_ARGS;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
p2 = xp_lisp_eval (lsp, RBL_CAR(RBL_CDR(p)));
|
||||||
|
if (p2 == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
if (xp_lisp_set (lsp->mem, p1, p2) == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
p = RBL_CDR(RBL_CDR(p));
|
||||||
|
}
|
||||||
|
|
||||||
|
return p2;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_quote (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
|
||||||
|
xp_lisp_assert (RBL_TYPE(args) == RBL_OBJ_CONS);
|
||||||
|
return RBL_CAR(args);
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_defun (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
/*
|
||||||
|
* (defun x (abc) x y z)
|
||||||
|
* (setq x (lambda (abc) x y z))
|
||||||
|
*/
|
||||||
|
|
||||||
|
xp_lisp_obj_t* name, * fun;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 3, RBL_PRIM_MAX_ARG_COUNT);
|
||||||
|
|
||||||
|
name = RBL_CAR(args);
|
||||||
|
if (RBL_TYPE(name) != RBL_OBJ_SYMBOL) {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
fun = xp_lisp_make_func (lsp->mem,
|
||||||
|
RBL_CAR(RBL_CDR(args)), RBL_CDR(RBL_CDR(args)));
|
||||||
|
if (fun == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
if (xp_lisp_set (lsp->mem, RBL_CAR(args), fun) == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
return fun;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_demac (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
/*
|
||||||
|
* (demac x (abc) x y z)
|
||||||
|
*(setq x (macro (abc) x y z))
|
||||||
|
*/
|
||||||
|
|
||||||
|
xp_lisp_obj_t* name, * mac;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 3, RBL_PRIM_MAX_ARG_COUNT);
|
||||||
|
|
||||||
|
name = RBL_CAR(args);
|
||||||
|
if (RBL_TYPE(name) != RBL_OBJ_SYMBOL) {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
mac = xp_lisp_make_macro (lsp->mem,
|
||||||
|
RBL_CAR(RBL_CDR(args)), RBL_CDR(RBL_CDR(args)));
|
||||||
|
if (mac == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
if (xp_lisp_set (lsp->mem, RBL_CAR(args), mac) == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
return mac;
|
||||||
|
}
|
||||||
|
|
||||||
|
static xp_lisp_obj_t* xp_lisp_prim_let_impl (
|
||||||
|
xp_lisp_t* lsp, xp_lisp_obj_t* args, int sequential)
|
||||||
|
{
|
||||||
|
xp_lisp_frame_t* frame;
|
||||||
|
xp_lisp_obj_t* assoc;
|
||||||
|
xp_lisp_obj_t* body;
|
||||||
|
xp_lisp_obj_t* value;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 1, RBL_PRIM_MAX_ARG_COUNT);
|
||||||
|
|
||||||
|
// create a new frame
|
||||||
|
frame = xp_lisp_frame_new ();
|
||||||
|
if (frame == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
//frame->link = lsp->mem->frame;
|
||||||
|
|
||||||
|
if (sequential) {
|
||||||
|
frame->link = lsp->mem->frame;
|
||||||
|
lsp->mem->frame = frame;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
frame->link = lsp->mem->brooding_frame;
|
||||||
|
lsp->mem->brooding_frame = frame;
|
||||||
|
}
|
||||||
|
|
||||||
|
assoc = RBL_CAR(args);
|
||||||
|
|
||||||
|
//while (assoc != lsp->mem->nil) {
|
||||||
|
while (RBL_TYPE(assoc) == RBL_OBJ_CONS) {
|
||||||
|
xp_lisp_obj_t* ass = RBL_CAR(assoc);
|
||||||
|
if (RBL_TYPE(ass) == RBL_OBJ_CONS) {
|
||||||
|
xp_lisp_obj_t* n = RBL_CAR(ass);
|
||||||
|
xp_lisp_obj_t* v = RBL_CDR(ass);
|
||||||
|
|
||||||
|
if (RBL_TYPE(n) != RBL_OBJ_SYMBOL) {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG; // must be a symbol
|
||||||
|
if (sequential) lsp->mem->frame = frame->link;
|
||||||
|
else lsp->mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
if (v != lsp->mem->nil) {
|
||||||
|
if (RBL_CDR(v) != lsp->mem->nil) {
|
||||||
|
lsp->error = RBL_ERR_TOO_MANY_ARGS; // must be a symbol
|
||||||
|
if (sequential) lsp->mem->frame = frame->link;
|
||||||
|
else lsp->mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
if ((v = xp_lisp_eval(lsp, RBL_CAR(v))) == XP_NULL) {
|
||||||
|
if (sequential) lsp->mem->frame = frame->link;
|
||||||
|
else lsp->mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
if (xp_lisp_frame_lookup (frame, n) != XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_DUP_FORMAL;
|
||||||
|
if (sequential) lsp->mem->frame = frame->link;
|
||||||
|
else lsp->mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
if (xp_lisp_frame_insert (frame, n, v) == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
if (sequential) lsp->mem->frame = frame->link;
|
||||||
|
else lsp->mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(ass) == RBL_OBJ_SYMBOL) {
|
||||||
|
if (xp_lisp_frame_lookup (frame, ass) != XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_DUP_FORMAL;
|
||||||
|
if (sequential) lsp->mem->frame = frame->link;
|
||||||
|
else lsp->mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
if (xp_lisp_frame_insert (frame, ass, lsp->mem->nil) == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
if (sequential) lsp->mem->frame = frame->link;
|
||||||
|
else lsp->mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG;
|
||||||
|
if (sequential) lsp->mem->frame = frame->link;
|
||||||
|
else lsp->mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
assoc = RBL_CDR(assoc);
|
||||||
|
}
|
||||||
|
|
||||||
|
if (assoc != lsp->mem->nil) {
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG;
|
||||||
|
if (sequential) lsp->mem->frame = frame->link;
|
||||||
|
else lsp->mem->brooding_frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
// 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;
|
||||||
|
body = RBL_CDR(args);
|
||||||
|
while (body != lsp->mem->nil) {
|
||||||
|
value = xp_lisp_eval (lsp, RBL_CAR(body));
|
||||||
|
if (value == XP_NULL) {
|
||||||
|
lsp->mem->frame = frame->link;
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
body = RBL_CDR(body);
|
||||||
|
}
|
||||||
|
|
||||||
|
// pop the frame
|
||||||
|
lsp->mem->frame = frame->link;
|
||||||
|
|
||||||
|
// destroy the frame
|
||||||
|
xp_lisp_frame_free (frame);
|
||||||
|
return value;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_let (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
return xp_lisp_prim_let_impl (lsp, args, 0);
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_letx (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
return xp_lisp_prim_let_impl (lsp, args, 1);
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_plus (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* body, * tmp;
|
||||||
|
xp_lisp_int value = 0;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 1, RBL_PRIM_MAX_ARG_COUNT);
|
||||||
|
xp_lisp_assert (RBL_TYPE(args) == RBL_OBJ_CONS);
|
||||||
|
|
||||||
|
body = args;
|
||||||
|
//while (body != lsp->mem->nil) {
|
||||||
|
while (RBL_TYPE(body) == RBL_OBJ_CONS) {
|
||||||
|
tmp = xp_lisp_eval (lsp, RBL_CAR(body));
|
||||||
|
if (tmp == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
if (RBL_TYPE(tmp) != RBL_OBJ_INT) {
|
||||||
|
lsp->error = RBL_ERR_BAD_VALUE;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
value = value + RBL_IVALUE(tmp);
|
||||||
|
body = RBL_CDR(body);
|
||||||
|
}
|
||||||
|
|
||||||
|
tmp = xp_lisp_make_int (lsp->mem, value);
|
||||||
|
if (tmp == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
return tmp;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_gt (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* p1, * p2;
|
||||||
|
int res;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
|
||||||
|
xp_lisp_assert (RBL_TYPE(args) == RBL_OBJ_CONS);
|
||||||
|
|
||||||
|
p1 = xp_lisp_eval (lsp, RBL_CAR(args));
|
||||||
|
if (p1 == XP_NULL) return XP_NULL;
|
||||||
|
// TODO: lock p1....
|
||||||
|
|
||||||
|
p2 = xp_lisp_eval (lsp, RBL_CAR(RBL_CDR(args)));
|
||||||
|
if (p2 == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
if (RBL_TYPE(p1) == RBL_OBJ_INT) {
|
||||||
|
if (RBL_TYPE(p2) == RBL_OBJ_INT) {
|
||||||
|
res = RBL_IVALUE(p1) > RBL_IVALUE(p2);
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(p2) == RBL_OBJ_FLOAT) {
|
||||||
|
res = RBL_IVALUE(p1) > RBL_FVALUE(p2);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
lsp->error = RBL_ERR_BAD_VALUE;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(p1) == RBL_OBJ_FLOAT) {
|
||||||
|
if (RBL_TYPE(p2) == RBL_OBJ_INT) {
|
||||||
|
res = RBL_FVALUE(p1) > RBL_IVALUE(p2);
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(p2) == RBL_OBJ_FLOAT) {
|
||||||
|
res = RBL_FVALUE(p1) > RBL_FVALUE(p2);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
lsp->error = RBL_ERR_BAD_VALUE;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(p1) == RBL_OBJ_SYMBOL) {
|
||||||
|
if (RBL_TYPE(p2) == RBL_OBJ_SYMBOL) {
|
||||||
|
res = xp_lisp_comp_symbol2 (
|
||||||
|
p1, RBL_SYMVALUE(p2), RBL_SYMLEN(p2)) > 0;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
lsp->error = RBL_ERR_BAD_VALUE;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(p1) == RBL_OBJ_STRING) {
|
||||||
|
if (RBL_TYPE(p2) == RBL_OBJ_STRING) {
|
||||||
|
res = xp_lisp_comp_string2 (
|
||||||
|
p1, RBL_STRVALUE(p2), RBL_STRLEN(p2)) > 0;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
lsp->error = RBL_ERR_BAD_VALUE;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
lsp->error = RBL_ERR_BAD_VALUE;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
return (res)? lsp->mem->t: lsp->mem->nil;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_lt (xp_lisp_t* lsp, xp_lisp_obj_t* args)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* p1, * p2;
|
||||||
|
int res;
|
||||||
|
|
||||||
|
RBL_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
|
||||||
|
xp_lisp_assert (RBL_TYPE(args) == RBL_OBJ_CONS);
|
||||||
|
|
||||||
|
p1 = xp_lisp_eval (lsp, RBL_CAR(args));
|
||||||
|
if (p1 == XP_NULL) return XP_NULL;
|
||||||
|
// TODO: lock p1....
|
||||||
|
|
||||||
|
p2 = xp_lisp_eval (lsp, RBL_CAR(RBL_CDR(args)));
|
||||||
|
if (p2 == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
if (RBL_TYPE(p1) == RBL_OBJ_INT) {
|
||||||
|
if (RBL_TYPE(p2) == RBL_OBJ_INT) {
|
||||||
|
res = RBL_IVALUE(p1) < RBL_IVALUE(p2);
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(p2) == RBL_OBJ_FLOAT) {
|
||||||
|
res = RBL_IVALUE(p1) < RBL_FVALUE(p2);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
lsp->error = RBL_ERR_BAD_VALUE;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(p1) == RBL_OBJ_FLOAT) {
|
||||||
|
if (RBL_TYPE(p2) == RBL_OBJ_INT) {
|
||||||
|
res = RBL_FVALUE(p1) < RBL_IVALUE(p2);
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(p2) == RBL_OBJ_FLOAT) {
|
||||||
|
res = RBL_FVALUE(p1) < RBL_FVALUE(p2);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
lsp->error = RBL_ERR_BAD_VALUE;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(p1) == RBL_OBJ_SYMBOL) {
|
||||||
|
if (RBL_TYPE(p2) == RBL_OBJ_SYMBOL) {
|
||||||
|
res = xp_lisp_comp_symbol2 (
|
||||||
|
p1, RBL_SYMVALUE(p2), RBL_SYMLEN(p2)) < 0;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
lsp->error = RBL_ERR_BAD_VALUE;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (RBL_TYPE(p1) == RBL_OBJ_STRING) {
|
||||||
|
if (RBL_TYPE(p2) == RBL_OBJ_STRING) {
|
||||||
|
res = xp_lisp_comp_string2 (
|
||||||
|
p1, RBL_STRVALUE(p2), RBL_STRLEN(p2)) < 0;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
lsp->error = RBL_ERR_BAD_VALUE;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
lsp->error = RBL_ERR_BAD_VALUE;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
return (res)? lsp->mem->t: lsp->mem->nil;
|
||||||
|
}
|
64
ase/lsp/primitive.h
Normal file
64
ase/lsp/primitive.h
Normal file
@ -0,0 +1,64 @@
|
|||||||
|
/*
|
||||||
|
* $Id: primitive.h,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#ifndef _RBL_PRIM_H_
|
||||||
|
#define _RBL_PRIM_H_
|
||||||
|
|
||||||
|
#include "types.h"
|
||||||
|
#include "lsp.h"
|
||||||
|
|
||||||
|
typedef xp_lisp_obj_t* (*xp_lisp_pimpl_t) (xp_lisp_t*, xp_lisp_obj_t*);
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
extern "C" {
|
||||||
|
#endif
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_abort (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_eval (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_prog1 (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_progn (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_gc (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_cond (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_if (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_while (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_car (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_cdr (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_cons (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_set (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_setq (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_quote (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_defun (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_demac (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_let (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_letx (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_plus (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_gt (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
xp_lisp_obj_t* xp_lisp_prim_lt (xp_lisp_t*, xp_lisp_obj_t* args);
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#define RBL_PRIM_CHECK_ARG_COUNT(lsp,args,min,max) \
|
||||||
|
{ \
|
||||||
|
xp_size_t count; \
|
||||||
|
if (xp_lisp_probe_args(lsp->mem, args, &count) == -1) { \
|
||||||
|
lsp->error = RBL_ERR_BAD_ARG; \
|
||||||
|
return XP_NULL; \
|
||||||
|
} \
|
||||||
|
if (count < min) { \
|
||||||
|
lsp->error = RBL_ERR_TOO_FEW_ARGS; \
|
||||||
|
return XP_NULL; \
|
||||||
|
} \
|
||||||
|
if (count > max) { \
|
||||||
|
lsp->error = RBL_ERR_TOO_MANY_ARGS; \
|
||||||
|
return XP_NULL; \
|
||||||
|
} \
|
||||||
|
}
|
||||||
|
|
||||||
|
#define RBL_PRIM_MAX_ARG_COUNT ((xp_size_t)~(xp_size_t)0)
|
||||||
|
|
||||||
|
#endif
|
113
ase/lsp/print.c
Normal file
113
ase/lsp/print.c
Normal file
@ -0,0 +1,113 @@
|
|||||||
|
/*
|
||||||
|
* $Id: print.c,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#include "lsp.h"
|
||||||
|
|
||||||
|
void xp_lisp_print_debug (xp_lisp_obj_t* obj)
|
||||||
|
{
|
||||||
|
switch (RBL_TYPE(obj)) {
|
||||||
|
case RBL_OBJ_NIL:
|
||||||
|
rb_printf ( RBL_TEXT("nil"));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_TRUE:
|
||||||
|
rb_printf ( RBL_TEXT("t"));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_INT:
|
||||||
|
rb_printf ( RBL_TEXT("%d"), RBL_IVALUE(obj));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_FLOAT:
|
||||||
|
rb_printf ( RBL_TEXT("%f"), RBL_FVALUE(obj));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_SYMBOL:
|
||||||
|
rb_printf ( RBL_TEXT("%s"), RBL_SYMVALUE(obj));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_STRING:
|
||||||
|
rb_printf ( RBL_TEXT("%s"), RBL_STRVALUE(obj));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_CONS:
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* p = obj;
|
||||||
|
rb_printf ( RBL_TEXT("("));
|
||||||
|
do {
|
||||||
|
xp_lisp_print_debug (RBL_CAR(p));
|
||||||
|
p = RBL_CDR(p);
|
||||||
|
if (RBL_TYPE(p) != RBL_OBJ_NIL) {
|
||||||
|
rb_printf ( RBL_TEXT(" "));
|
||||||
|
if (RBL_TYPE(p) != RBL_OBJ_CONS) {
|
||||||
|
rb_printf ( RBL_TEXT(". "));
|
||||||
|
xp_lisp_print_debug (p);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
} while (RBL_TYPE(p) != RBL_OBJ_NIL && RBL_TYPE(p) == RBL_OBJ_CONS);
|
||||||
|
rb_printf ( RBL_TEXT(")"));
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_FUNC:
|
||||||
|
rb_printf ( RBL_TEXT("func"));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_MACRO:
|
||||||
|
rb_printf (RBL_TEXT("macro"));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_PRIM:
|
||||||
|
rb_printf (RBL_TEXT("prim"));
|
||||||
|
break;
|
||||||
|
default:
|
||||||
|
rb_printf (RBL_TEXT("unknown object type: %d"), RBL_TYPE(obj));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_print (xp_lisp_t* lsp, xp_lisp_obj_t* obj)
|
||||||
|
{
|
||||||
|
switch (RBL_TYPE(obj)) {
|
||||||
|
case RBL_OBJ_NIL:
|
||||||
|
rb_fprintf (lsp->outstream, RBL_TEXT("nil"));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_TRUE:
|
||||||
|
rb_fprintf (lsp->outstream, RBL_TEXT("t"));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_INT:
|
||||||
|
rb_fprintf (lsp->outstream, RBL_TEXT("%d"), RBL_IVALUE(obj));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_FLOAT:
|
||||||
|
rb_fprintf (lsp->outstream, RBL_TEXT("%f"), RBL_FVALUE(obj));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_SYMBOL:
|
||||||
|
rb_fprintf (lsp->outstream, RBL_TEXT("%s"), RBL_SYMVALUE(obj));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_STRING:
|
||||||
|
rb_fprintf (lsp->outstream, RBL_TEXT("\"%s\""), RBL_STRVALUE(obj));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_CONS:
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* p = obj;
|
||||||
|
rb_fprintf (lsp->outstream, RBL_TEXT("("));
|
||||||
|
do {
|
||||||
|
xp_lisp_print (lsp, RBL_CAR(p));
|
||||||
|
p = RBL_CDR(p);
|
||||||
|
if (p != lsp->mem->nil) {
|
||||||
|
rb_fprintf (lsp->outstream, RBL_TEXT(" "));
|
||||||
|
if (RBL_TYPE(p) != RBL_OBJ_CONS) {
|
||||||
|
rb_fprintf (lsp->outstream, RBL_TEXT(". "));
|
||||||
|
xp_lisp_print (lsp, p);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
} while (p != lsp->mem->nil && RBL_TYPE(p) == RBL_OBJ_CONS);
|
||||||
|
rb_fprintf (lsp->outstream, RBL_TEXT(")"));
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_FUNC:
|
||||||
|
rb_fprintf (lsp->outstream, RBL_TEXT("func"));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_MACRO:
|
||||||
|
rb_fprintf (lsp->outstream, RBL_TEXT("macro"));
|
||||||
|
break;
|
||||||
|
case RBL_OBJ_PRIM:
|
||||||
|
rb_fprintf (lsp->outstream, RBL_TEXT("prim"));
|
||||||
|
break;
|
||||||
|
default:
|
||||||
|
rb_fprintf (lsp->outstream,
|
||||||
|
RBL_TEXT("unknown object type: %d"), RBL_TYPE(obj));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
413
ase/lsp/read.c
Normal file
413
ase/lsp/read.c
Normal file
@ -0,0 +1,413 @@
|
|||||||
|
/*
|
||||||
|
* $Id: read.c,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#include "lsp.h"
|
||||||
|
#include "token.h"
|
||||||
|
|
||||||
|
#define IS_SPACE(x) rb_isspace(x)
|
||||||
|
#define IS_DIGIT(x) rb_isdigit(x)
|
||||||
|
#define IS_ALPHA(x) rb_isalpha(x)
|
||||||
|
#define IS_ALNUM(x) rb_isalnum(x)
|
||||||
|
|
||||||
|
#define IS_IDENT(c) \
|
||||||
|
((c) == RBL_CHAR('+') || (c) == RBL_CHAR('-') || \
|
||||||
|
(c) == RBL_CHAR('*') || (c) == RBL_CHAR('/') || \
|
||||||
|
(c) == RBL_CHAR('%') || (c) == RBL_CHAR('&') || \
|
||||||
|
(c) == RBL_CHAR('<') || (c) == RBL_CHAR('>') || \
|
||||||
|
(c) == RBL_CHAR('=') || (c) == RBL_CHAR('_') || \
|
||||||
|
(c) == RBL_CHAR('?'))
|
||||||
|
|
||||||
|
#define TOKEN_CLEAR(lsp) xp_lisp_token_clear (lsp->token)
|
||||||
|
#define TOKEN_TYPE(lsp) lsp->token->type
|
||||||
|
#define TOKEN_IVALUE(lsp) lsp->token->ivalue
|
||||||
|
#define TOKEN_FVALUE(lsp) lsp->token->fvalue
|
||||||
|
#define TOKEN_SVALUE(lsp) lsp->token->buffer
|
||||||
|
#define TOKEN_SLENGTH(lsp) lsp->token->size
|
||||||
|
#define TOKEN_ADD_CHAR(lsp,ch) \
|
||||||
|
do { \
|
||||||
|
if (xp_lisp_token_addc (lsp->token, ch) == -1) { \
|
||||||
|
lsp->error = RBL_ERR_MEM; \
|
||||||
|
return -1; \
|
||||||
|
} \
|
||||||
|
} while (0)
|
||||||
|
#define TOKEN_COMPARE(lsp,str) xp_lisp_token_compare (lsp->token, str)
|
||||||
|
|
||||||
|
|
||||||
|
#define TOKEN_END 0
|
||||||
|
#define TOKEN_INT 1
|
||||||
|
#define TOKEN_FLOAT 2
|
||||||
|
#define TOKEN_STRING 3
|
||||||
|
#define TOKEN_LPAREN 4
|
||||||
|
#define TOKEN_RPAREN 5
|
||||||
|
#define TOKEN_IDENT 6
|
||||||
|
#define TOKEN_QUOTE 7
|
||||||
|
#define TOKEN_DOT 8
|
||||||
|
#define TOKEN_INVALID 50
|
||||||
|
#define TOKEN_UNTERM_STRING 51
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
extern "C" {
|
||||||
|
#endif
|
||||||
|
|
||||||
|
static xp_lisp_obj_t* read_obj (xp_lisp_t* lsp);
|
||||||
|
static xp_lisp_obj_t* read_list (xp_lisp_t* lsp);
|
||||||
|
static xp_lisp_obj_t* read_quote (xp_lisp_t* lsp);
|
||||||
|
|
||||||
|
static int read_token (xp_lisp_t* lsp);
|
||||||
|
static int read_number (xp_lisp_t* lsp, int negative);
|
||||||
|
static int read_ident (xp_lisp_t* lsp);
|
||||||
|
static int read_string (xp_lisp_t* lsp);
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#define NEXT_CHAR(lsp) \
|
||||||
|
do { \
|
||||||
|
if (lsp->creader (&lsp->curc, lsp->creader_extra) == -1) { \
|
||||||
|
lsp->error = RBL_ERR_READ; \
|
||||||
|
return -1; \
|
||||||
|
} \
|
||||||
|
} while (0)
|
||||||
|
|
||||||
|
#define NEXT_TOKEN(lsp) \
|
||||||
|
do { \
|
||||||
|
if (read_token(lsp) == -1) return XP_NULL; \
|
||||||
|
} while (0)
|
||||||
|
|
||||||
|
|
||||||
|
void xp_lisp_set_creader (xp_lisp_t* lsp, xp_lisp_creader_t func, void* extra)
|
||||||
|
{
|
||||||
|
xp_lisp_assert (lsp != XP_NULL);
|
||||||
|
|
||||||
|
lsp->creader = func;
|
||||||
|
lsp->creader_extra = extra;
|
||||||
|
lsp->creader_just_set = 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_obj_t* xp_lisp_read (xp_lisp_t* lsp)
|
||||||
|
{
|
||||||
|
xp_lisp_assert (lsp != XP_NULL && lsp->creader != XP_NULL);
|
||||||
|
|
||||||
|
if (lsp->creader_just_set) {
|
||||||
|
// NEXT_CHAR (lsp);
|
||||||
|
if (lsp->creader (&lsp->curc, lsp->creader_extra) == -1) {
|
||||||
|
lsp->error = RBL_ERR_READ;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
lsp->creader_just_set = 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
lsp->error = RBL_ERR_NONE;
|
||||||
|
NEXT_TOKEN (lsp);
|
||||||
|
|
||||||
|
if (lsp->mem->locked != XP_NULL) {
|
||||||
|
xp_lisp_unlock_all (lsp->mem->locked);
|
||||||
|
lsp->mem->locked = XP_NULL;
|
||||||
|
}
|
||||||
|
lsp->mem->locked = read_obj (lsp);
|
||||||
|
return lsp->mem->locked;
|
||||||
|
}
|
||||||
|
|
||||||
|
static xp_lisp_obj_t* read_obj (xp_lisp_t* lsp)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* obj;
|
||||||
|
|
||||||
|
switch (TOKEN_TYPE(lsp)) {
|
||||||
|
case TOKEN_END:
|
||||||
|
lsp->error = RBL_ERR_END;
|
||||||
|
return XP_NULL;
|
||||||
|
case TOKEN_LPAREN:
|
||||||
|
NEXT_TOKEN (lsp);
|
||||||
|
return read_list (lsp);
|
||||||
|
case TOKEN_QUOTE:
|
||||||
|
NEXT_TOKEN (lsp);
|
||||||
|
return read_quote (lsp);
|
||||||
|
case TOKEN_INT:
|
||||||
|
obj = xp_lisp_make_int (lsp->mem, TOKEN_IVALUE(lsp));
|
||||||
|
if (obj == XP_NULL) lsp->error = RBL_ERR_MEM;
|
||||||
|
xp_lisp_lock (obj);
|
||||||
|
return obj;
|
||||||
|
case TOKEN_FLOAT:
|
||||||
|
obj = xp_lisp_make_float (lsp->mem, TOKEN_FVALUE(lsp));
|
||||||
|
if (obj == XP_NULL) lsp->error = RBL_ERR_MEM;
|
||||||
|
xp_lisp_lock (obj);
|
||||||
|
return obj;
|
||||||
|
case TOKEN_STRING:
|
||||||
|
obj = xp_lisp_make_string (
|
||||||
|
lsp->mem, TOKEN_SVALUE(lsp), TOKEN_SLENGTH(lsp));
|
||||||
|
if (obj == XP_NULL) lsp->error = RBL_ERR_MEM;
|
||||||
|
xp_lisp_lock (obj);
|
||||||
|
return obj;
|
||||||
|
case TOKEN_IDENT:
|
||||||
|
xp_lisp_assert (lsp->mem->nil != XP_NULL && lsp->mem->t != XP_NULL);
|
||||||
|
if (TOKEN_COMPARE(lsp, RBL_TEXT("nil")) == 0) obj = lsp->mem->nil;
|
||||||
|
else if (TOKEN_COMPARE(lsp, RBL_TEXT("t")) == 0) obj = lsp->mem->t;
|
||||||
|
else {
|
||||||
|
obj = xp_lisp_make_symbol (
|
||||||
|
lsp->mem, TOKEN_SVALUE(lsp), TOKEN_SLENGTH(lsp));
|
||||||
|
if (obj == XP_NULL) lsp->error = RBL_ERR_MEM;
|
||||||
|
xp_lisp_lock (obj);
|
||||||
|
}
|
||||||
|
return obj;
|
||||||
|
}
|
||||||
|
|
||||||
|
lsp->error = RBL_ERR_SYNTAX;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
static xp_lisp_obj_t* read_list (xp_lisp_t* lsp)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* obj;
|
||||||
|
xp_lisp_obj_cons_t* p, * first = XP_NULL, * prev = XP_NULL;
|
||||||
|
|
||||||
|
while (TOKEN_TYPE(lsp) != TOKEN_RPAREN) {
|
||||||
|
if (TOKEN_TYPE(lsp) == TOKEN_END) {
|
||||||
|
lsp->error = RBL_ERR_SYNTAX; // unexpected end of input
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
if (TOKEN_TYPE(lsp) == TOKEN_DOT) {
|
||||||
|
if (prev == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_SYNTAX; // unexpected .
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
NEXT_TOKEN (lsp);
|
||||||
|
obj = read_obj (lsp);
|
||||||
|
if (obj == XP_NULL) {
|
||||||
|
if (lsp->error == RBL_ERR_END) {
|
||||||
|
//unexpected end of input
|
||||||
|
lsp->error = RBL_ERR_SYNTAX;
|
||||||
|
}
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
prev->cdr = obj;
|
||||||
|
|
||||||
|
NEXT_TOKEN (lsp);
|
||||||
|
if (TOKEN_TYPE(lsp) != TOKEN_RPAREN) {
|
||||||
|
lsp->error = RBL_ERR_SYNTAX; // ) expected
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
|
||||||
|
obj = read_obj (lsp);
|
||||||
|
if (obj == XP_NULL) {
|
||||||
|
if (lsp->error == RBL_ERR_END) {
|
||||||
|
// unexpected end of input
|
||||||
|
lsp->error = RBL_ERR_SYNTAX;
|
||||||
|
}
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
p = (xp_lisp_obj_cons_t*)xp_lisp_make_cons (
|
||||||
|
lsp->mem, lsp->mem->nil, lsp->mem->nil);
|
||||||
|
if (p == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
xp_lisp_lock ((xp_lisp_obj_t*)p);
|
||||||
|
|
||||||
|
if (first == XP_NULL) first = p;
|
||||||
|
if (prev != XP_NULL) prev->cdr = (xp_lisp_obj_t*)p;
|
||||||
|
|
||||||
|
p->car = obj;
|
||||||
|
prev = p;
|
||||||
|
|
||||||
|
NEXT_TOKEN (lsp);
|
||||||
|
}
|
||||||
|
|
||||||
|
return (first == XP_NULL)? lsp->mem->nil: (xp_lisp_obj_t*)first;
|
||||||
|
}
|
||||||
|
|
||||||
|
static xp_lisp_obj_t* read_quote (xp_lisp_t* lsp)
|
||||||
|
{
|
||||||
|
xp_lisp_obj_t* cons, * tmp;
|
||||||
|
|
||||||
|
tmp = read_obj (lsp);
|
||||||
|
if (tmp == XP_NULL) {
|
||||||
|
if (lsp->error == RBL_ERR_END) {
|
||||||
|
// unexpected end of input
|
||||||
|
lsp->error = RBL_ERR_SYNTAX;
|
||||||
|
}
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
cons = xp_lisp_make_cons (lsp->mem, tmp, lsp->mem->nil);
|
||||||
|
if (cons == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
xp_lisp_lock (cons);
|
||||||
|
|
||||||
|
cons = xp_lisp_make_cons (lsp->mem, lsp->mem->quote, cons);
|
||||||
|
if (cons == XP_NULL) {
|
||||||
|
lsp->error = RBL_ERR_MEM;
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
xp_lisp_lock (cons);
|
||||||
|
|
||||||
|
return cons;
|
||||||
|
}
|
||||||
|
|
||||||
|
static int read_token (xp_lisp_t* lsp)
|
||||||
|
{
|
||||||
|
xp_lisp_assert (lsp->creader != XP_NULL);
|
||||||
|
|
||||||
|
TOKEN_CLEAR (lsp);
|
||||||
|
|
||||||
|
for (;;) {
|
||||||
|
// skip white spaces
|
||||||
|
while (IS_SPACE(lsp->curc)) NEXT_CHAR (lsp);
|
||||||
|
|
||||||
|
// skip the comments here
|
||||||
|
if (lsp->curc == RBL_CHAR(';')) {
|
||||||
|
do {
|
||||||
|
NEXT_CHAR (lsp);
|
||||||
|
} while (lsp->curc != RBL_CHAR('\n') && lsp->curc != RBL_CHAR_END);
|
||||||
|
}
|
||||||
|
else break;
|
||||||
|
}
|
||||||
|
|
||||||
|
if (lsp->curc == RBL_CHAR_END) {
|
||||||
|
TOKEN_TYPE(lsp) = TOKEN_END;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
else if (lsp->curc == RBL_CHAR('(')) {
|
||||||
|
TOKEN_ADD_CHAR (lsp, lsp->curc);
|
||||||
|
TOKEN_TYPE(lsp) = TOKEN_LPAREN;
|
||||||
|
NEXT_CHAR (lsp);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
else if (lsp->curc == RBL_CHAR(')')) {
|
||||||
|
TOKEN_ADD_CHAR (lsp, lsp->curc);
|
||||||
|
TOKEN_TYPE(lsp) = TOKEN_RPAREN;
|
||||||
|
NEXT_CHAR (lsp);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
else if (lsp->curc == RBL_CHAR('\'')) {
|
||||||
|
TOKEN_ADD_CHAR (lsp, lsp->curc);
|
||||||
|
TOKEN_TYPE(lsp) = TOKEN_QUOTE;
|
||||||
|
NEXT_CHAR (lsp);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
else if (lsp->curc == RBL_CHAR('.')) {
|
||||||
|
TOKEN_ADD_CHAR (lsp, lsp->curc);
|
||||||
|
TOKEN_TYPE(lsp) = TOKEN_DOT;
|
||||||
|
NEXT_CHAR (lsp);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
else if (lsp->curc == RBL_CHAR('-')) {
|
||||||
|
TOKEN_ADD_CHAR (lsp, lsp->curc);
|
||||||
|
NEXT_CHAR (lsp);
|
||||||
|
return (IS_DIGIT(lsp->curc))?
|
||||||
|
read_number (lsp, 1): read_ident (lsp);
|
||||||
|
}
|
||||||
|
else if (IS_DIGIT(lsp->curc)) {
|
||||||
|
return read_number (lsp, 0);
|
||||||
|
}
|
||||||
|
else if (IS_ALPHA(lsp->curc) || IS_IDENT(lsp->curc)) {
|
||||||
|
return read_ident (lsp);
|
||||||
|
}
|
||||||
|
else if (lsp->curc == RBL_CHAR('\"')) {
|
||||||
|
NEXT_CHAR (lsp);
|
||||||
|
return read_string (lsp);
|
||||||
|
}
|
||||||
|
|
||||||
|
TOKEN_TYPE(lsp) = TOKEN_INVALID;
|
||||||
|
NEXT_CHAR (lsp); // consume
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
static int read_number (xp_lisp_t* lsp, int negative)
|
||||||
|
{
|
||||||
|
do {
|
||||||
|
TOKEN_IVALUE(lsp) =
|
||||||
|
TOKEN_IVALUE(lsp) * 10 + lsp->curc - RBL_CHAR('0');
|
||||||
|
TOKEN_ADD_CHAR (lsp, lsp->curc);
|
||||||
|
NEXT_CHAR (lsp);
|
||||||
|
} while (IS_DIGIT(lsp->curc));
|
||||||
|
|
||||||
|
if (negative) TOKEN_IVALUE(lsp) *= -1;
|
||||||
|
TOKEN_TYPE(lsp) = TOKEN_INT;
|
||||||
|
|
||||||
|
// TODO: read floating point numbers
|
||||||
|
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
static int read_ident (xp_lisp_t* lsp)
|
||||||
|
{
|
||||||
|
do {
|
||||||
|
TOKEN_ADD_CHAR (lsp, lsp->curc);
|
||||||
|
NEXT_CHAR (lsp);
|
||||||
|
} while (IS_ALNUM(lsp->curc) || IS_IDENT(lsp->curc));
|
||||||
|
TOKEN_TYPE(lsp) = TOKEN_IDENT;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
static int read_string (xp_lisp_t* lsp)
|
||||||
|
{
|
||||||
|
int escaped = 0;
|
||||||
|
xp_lisp_cint code = 0;
|
||||||
|
|
||||||
|
do {
|
||||||
|
if (lsp->curc == RBL_CHAR_END) {
|
||||||
|
TOKEN_TYPE(lsp) = TOKEN_UNTERM_STRING;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
// TODO:
|
||||||
|
if (escaped == 3) {
|
||||||
|
/* \xNN */
|
||||||
|
}
|
||||||
|
else if (escaped == 2) {
|
||||||
|
/* \000 */
|
||||||
|
}
|
||||||
|
else if (escaped == 1) {
|
||||||
|
/* backslash + character */
|
||||||
|
if (lsp->curc == RBL_CHAR('a'))
|
||||||
|
lsp->curc = RBL_CHAR('\a');
|
||||||
|
else if (lsp->curc == RBL_CHAR('b'))
|
||||||
|
lsp->curc = RBL_CHAR('\b');
|
||||||
|
else if (lsp->curc == RBL_CHAR('f'))
|
||||||
|
lsp->curc = RBL_CHAR('\f');
|
||||||
|
else if (lsp->curc == RBL_CHAR('n'))
|
||||||
|
lsp->curc = RBL_CHAR('\n');
|
||||||
|
else if (lsp->curc == RBL_CHAR('r'))
|
||||||
|
lsp->curc = RBL_CHAR('\r');
|
||||||
|
else if (lsp->curc == RBL_CHAR('t'))
|
||||||
|
lsp->curc = RBL_CHAR('\t');
|
||||||
|
else if (lsp->curc == RBL_CHAR('v'))
|
||||||
|
lsp->curc = RBL_CHAR('\v');
|
||||||
|
else if (lsp->curc == RBL_CHAR('0')) {
|
||||||
|
escaped = 2;
|
||||||
|
code = 0;
|
||||||
|
NEXT_CHAR (lsp);
|
||||||
|
continue;
|
||||||
|
}
|
||||||
|
else if (lsp->curc == RBL_CHAR('x')) {
|
||||||
|
escaped = 3;
|
||||||
|
code = 0;
|
||||||
|
NEXT_CHAR (lsp);
|
||||||
|
continue;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else if (lsp->curc == RBL_CHAR('\\')) {
|
||||||
|
escaped = 1;
|
||||||
|
NEXT_CHAR (lsp);
|
||||||
|
continue;
|
||||||
|
}
|
||||||
|
|
||||||
|
TOKEN_ADD_CHAR (lsp, lsp->curc);
|
||||||
|
NEXT_CHAR (lsp);
|
||||||
|
} while (lsp->curc != RBL_CHAR('\"'));
|
||||||
|
|
||||||
|
TOKEN_TYPE(lsp) = TOKEN_STRING;
|
||||||
|
NEXT_CHAR (lsp);
|
||||||
|
|
||||||
|
return 0;
|
||||||
|
}
|
92
ase/lsp/token.c
Normal file
92
ase/lsp/token.c
Normal file
@ -0,0 +1,92 @@
|
|||||||
|
/*
|
||||||
|
* $Id: token.c,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#include "token.h"
|
||||||
|
#include <stdlib.h>
|
||||||
|
|
||||||
|
xp_lisp_token_t* xp_lisp_token_new (xp_size_t capacity)
|
||||||
|
{
|
||||||
|
xp_lisp_token_t* token;
|
||||||
|
|
||||||
|
xp_lisp_assert (capacity > 0);
|
||||||
|
|
||||||
|
token = (xp_lisp_token_t*)malloc (sizeof(xp_lisp_token_t));
|
||||||
|
if (token == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
token->buffer = (xp_lisp_char*)malloc ((capacity + 1) * sizeof(xp_lisp_char));
|
||||||
|
if (token->buffer == XP_NULL) {
|
||||||
|
free (token);
|
||||||
|
return XP_NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
token->ivalue = 0;
|
||||||
|
token->fvalue = .0;
|
||||||
|
|
||||||
|
token->size = 0;
|
||||||
|
token->capacity = capacity;
|
||||||
|
token->buffer[0] = RBL_CHAR('\0');
|
||||||
|
|
||||||
|
return token;
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_token_free (xp_lisp_token_t* token)
|
||||||
|
{
|
||||||
|
free (token->buffer);
|
||||||
|
free (token);
|
||||||
|
}
|
||||||
|
|
||||||
|
int xp_lisp_token_addc (xp_lisp_token_t* token, xp_lisp_cint c)
|
||||||
|
{
|
||||||
|
if (token->size >= token->capacity) {
|
||||||
|
// double the capacity.
|
||||||
|
xp_lisp_char* new_buffer = (xp_lisp_char*)realloc (
|
||||||
|
token->buffer, (token->capacity * 2 + 1) * sizeof(xp_lisp_char));
|
||||||
|
if (new_buffer == XP_NULL) return -1;
|
||||||
|
token->buffer = new_buffer;
|
||||||
|
token->capacity = token->capacity * 2;
|
||||||
|
}
|
||||||
|
|
||||||
|
token->buffer[token->size++] = c;
|
||||||
|
token->buffer[token->size] = RBL_CHAR('\0');
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void xp_lisp_token_clear (xp_lisp_token_t* token)
|
||||||
|
{
|
||||||
|
token->ivalue = 0;
|
||||||
|
token->fvalue = .0;
|
||||||
|
|
||||||
|
token->size = 0;
|
||||||
|
token->buffer[0] = RBL_CHAR('\0');
|
||||||
|
}
|
||||||
|
|
||||||
|
xp_lisp_char* xp_lisp_token_transfer (xp_lisp_token_t* token, xp_size_t capacity)
|
||||||
|
{
|
||||||
|
xp_lisp_char* old_buffer, * new_buffer;
|
||||||
|
|
||||||
|
new_buffer = (xp_lisp_char*)malloc((capacity + 1) * sizeof(xp_lisp_char));
|
||||||
|
if (new_buffer == XP_NULL) return XP_NULL;
|
||||||
|
|
||||||
|
old_buffer = token->buffer;
|
||||||
|
token->buffer = new_buffer;
|
||||||
|
token->size = 0;
|
||||||
|
token->capacity = capacity;
|
||||||
|
token->buffer[0] = RBL_CHAR('\0');
|
||||||
|
|
||||||
|
return old_buffer;
|
||||||
|
}
|
||||||
|
|
||||||
|
int xp_lisp_token_compare (xp_lisp_token_t* token, const xp_lisp_char* str)
|
||||||
|
{
|
||||||
|
xp_lisp_char* p = token->buffer;
|
||||||
|
xp_size_t index = 0;
|
||||||
|
|
||||||
|
while (index < token->size) {
|
||||||
|
if (*p > *str) return 1;
|
||||||
|
if (*p < *str) return -1;
|
||||||
|
index++; p++; str++;
|
||||||
|
}
|
||||||
|
|
||||||
|
return (*str == RBL_CHAR('\0'))? 0: -1;
|
||||||
|
}
|
39
ase/lsp/token.h
Normal file
39
ase/lsp/token.h
Normal file
@ -0,0 +1,39 @@
|
|||||||
|
/*
|
||||||
|
* $Id: token.h,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#ifndef _RBL_TOKEN_H_
|
||||||
|
#define _RBL_TOKEN_H_
|
||||||
|
|
||||||
|
#include "types.h"
|
||||||
|
|
||||||
|
struct xp_lisp_token_t
|
||||||
|
{
|
||||||
|
int type;
|
||||||
|
|
||||||
|
xp_lisp_int ivalue;
|
||||||
|
xp_lisp_float fvalue;
|
||||||
|
|
||||||
|
xp_size_t capacity;
|
||||||
|
xp_size_t size;
|
||||||
|
xp_lisp_char* buffer;
|
||||||
|
};
|
||||||
|
|
||||||
|
typedef struct xp_lisp_token_t xp_lisp_token_t;
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
extern "C" {
|
||||||
|
#endif
|
||||||
|
|
||||||
|
xp_lisp_token_t* xp_lisp_token_new (xp_size_t capacity);
|
||||||
|
void xp_lisp_token_free (xp_lisp_token_t* token);
|
||||||
|
int xp_lisp_token_addc (xp_lisp_token_t* token, xp_lisp_cint c);
|
||||||
|
void xp_lisp_token_clear (xp_lisp_token_t* token);
|
||||||
|
xp_lisp_char* xp_lisp_token_transfer (xp_lisp_token_t* token, xp_size_t capacity);
|
||||||
|
int xp_lisp_token_compare (xp_lisp_token_t* token, const xp_lisp_char* str);
|
||||||
|
|
||||||
|
#ifdef __cplusplus
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#endif
|
23
ase/lsp/types.h
Normal file
23
ase/lsp/types.h
Normal file
@ -0,0 +1,23 @@
|
|||||||
|
/*
|
||||||
|
* $Id: types.h,v 1.1 2005-02-04 15:39:11 bacon Exp $
|
||||||
|
*/
|
||||||
|
|
||||||
|
#ifndef _RBL_TYPES_H_
|
||||||
|
#define _RBL_TYPES_H_
|
||||||
|
|
||||||
|
#include <rb/types.h>
|
||||||
|
#include <rb/macros.h>
|
||||||
|
|
||||||
|
typedef rb_char xp_lisp_char;
|
||||||
|
typedef rb_cint xp_lisp_cint;
|
||||||
|
typedef int xp_lisp_int;
|
||||||
|
typedef float xp_lisp_float;
|
||||||
|
|
||||||
|
#define RBL_CHAR(x) RB_CHAR(x)
|
||||||
|
#define RBL_TEXT(x) RB_TEXT(x)
|
||||||
|
#define RBL_CHAR_END RB_EOF
|
||||||
|
|
||||||
|
#define xp_lisp_ensure(x) RB_ENSURE(x)
|
||||||
|
#define xp_lisp_assert(x) RB_ASSERT(x)
|
||||||
|
|
||||||
|
#endif
|
Loading…
Reference in New Issue
Block a user