414 lines
10 KiB
C
414 lines
10 KiB
C
/* Copyright 1989 GROUPE BULL -- See license conditions in file COPYRIGHT
|
|
* Copyright 1989 Massachusetts Institute of Technology
|
|
*/
|
|
/**************************\
|
|
* *
|
|
* WOOL_OBJECT: Namespace *
|
|
* BODY *
|
|
* *
|
|
\**************************/
|
|
|
|
#include "EXTERN.h"
|
|
#include <stdlib.h>
|
|
#include <stdio.h>
|
|
#include "wool.h"
|
|
#include "wl_atom.h"
|
|
#include "wl_list.h"
|
|
#include "wl_number.h"
|
|
#include "wl_string.h"
|
|
#include "INTERN.h"
|
|
#include "wl_name.h"
|
|
|
|
#define WLNAMESPACE_INITIAL_SIZE 3 /* initial size (in longs) */
|
|
#define DELETED (WOOL_OBJECT *) -1 /* slot is vacant */
|
|
#define NONE_DELETED -1 /* no slot is vacant */
|
|
|
|
int WLNamespace_search_deleted();
|
|
|
|
/* High level function callable from wool. Makes a new namespace.
|
|
*/
|
|
|
|
WOOL_Namespace
|
|
WLNamespace_make()
|
|
{
|
|
WOOL_Namespace object = (WOOL_Namespace)
|
|
Malloc(sizeof(struct _WOOL_Namespace));
|
|
|
|
bzero(object, sizeof(struct _WOOL_Namespace));
|
|
object -> type = WLNamespace;
|
|
zrt_put(object);
|
|
object -> first_deleted = NONE_DELETED;
|
|
return object;
|
|
}
|
|
|
|
/* adding a namespace domain to a namespace. returns int of created namespace
|
|
*/
|
|
|
|
WOOL_OBJECT
|
|
WLNamespace_add(namespace)
|
|
WOOL_Namespace namespace;
|
|
{
|
|
int new_index;
|
|
|
|
must_be_namespace(namespace, 0);
|
|
if (!namespace -> number) /* non-empty namespaces */
|
|
increase_reference(namespace); /* must never disapear */
|
|
if (namespace -> first_deleted == NONE_DELETED) {
|
|
new_index = namespace -> number++;
|
|
namespace -> namespaces = (WOOL_OBJECT **)
|
|
Realloc(namespace -> namespaces,
|
|
namespace -> number * sizeof(WOOL_OBJECT *));
|
|
} else {
|
|
new_index = namespace -> first_deleted;
|
|
namespace -> first_deleted =
|
|
WLNamespace_search_deleted(namespace, new_index);
|
|
}
|
|
if (namespace -> limit)
|
|
namespace -> namespaces[new_index] = (WOOL_OBJECT *)
|
|
Malloc(sizeof(WOOL_OBJECT) * namespace -> limit);
|
|
else
|
|
namespace -> namespaces[new_index] = 0;
|
|
return (WOOL_OBJECT) WLNumber_make(new_index);
|
|
}
|
|
|
|
/* removing a namespace.
|
|
* just puts a DELETED in the entry
|
|
*/
|
|
|
|
WOOL_OBJECT
|
|
WLNamespace_remove(namespace, number)
|
|
WOOL_Namespace namespace;
|
|
WOOL_Number number;
|
|
{
|
|
int index;
|
|
WOOL_OBJECT *p;
|
|
|
|
must_be_namespace(namespace, 0);
|
|
must_be_number(number, 1);
|
|
index = number -> number;
|
|
if (index < 0 || index >= namespace -> number)
|
|
return NIL;
|
|
for (p = namespace -> namespaces[index];
|
|
p < (namespace -> namespaces[index]) + namespace -> limit;
|
|
p++)
|
|
decrease_reference(*p);
|
|
Free(namespace -> namespaces[index]);
|
|
namespace -> namespaces[index] = DELETED;
|
|
if (namespace -> first_deleted == NONE_DELETED
|
|
|| namespace -> first_deleted > index)
|
|
namespace -> first_deleted = index;
|
|
return NIL;
|
|
}
|
|
|
|
/* searches for first vacant spot
|
|
*/
|
|
|
|
int
|
|
WLNamespace_search_deleted(namespace, index)
|
|
WOOL_Namespace namespace;
|
|
int index;
|
|
{
|
|
WOOL_OBJECT **p;
|
|
|
|
for (p = namespace -> namespaces + index;
|
|
p < namespace -> namespaces + namespace -> number;
|
|
p++) {
|
|
if (*p == DELETED)
|
|
return p - namespace -> namespaces;
|
|
}
|
|
return NONE_DELETED;
|
|
}
|
|
|
|
|
|
/* adding a new name entry in a namespace
|
|
* returns new index
|
|
*/
|
|
|
|
Num
|
|
WLNamespace_add_name(namespace)
|
|
WOOL_Namespace namespace;
|
|
{
|
|
int i;
|
|
WOOL_OBJECT *p;
|
|
|
|
if (namespace -> size >= namespace -> limit) { /* must realloc */
|
|
if (namespace -> limit)
|
|
namespace -> limit = namespace -> limit * 2 + 1;
|
|
else
|
|
namespace -> limit = WLNAMESPACE_INITIAL_SIZE;
|
|
for (i = 0; i < namespace -> number; i++) {
|
|
namespace -> namespaces[i] = (WOOL_OBJECT *) Realloc(
|
|
namespace -> namespaces[i],
|
|
namespace -> limit * sizeof(WOOL_OBJECT));
|
|
for (p = (namespace -> namespaces[i]) + namespace -> size;
|
|
p < (namespace -> namespaces[i]) + namespace -> limit;
|
|
p++)
|
|
increase_reference(*p = UNDEFINED_WOOL_VALUE);
|
|
}
|
|
}
|
|
return (Num) namespace -> size++;
|
|
}
|
|
|
|
/* adding a name in a namespace
|
|
* (defname 'name namespace [value]) ==> sets value in each namespace state
|
|
* if no value given, and atom had a previous value, sets all name values
|
|
* this value
|
|
*/
|
|
|
|
WOOL_OBJECT
|
|
WLName_add(argc, argv)
|
|
int argc;
|
|
WOOL_OBJECT argv[];
|
|
{
|
|
WOOL_OBJECT value;
|
|
|
|
switch (argc) {
|
|
case 2:
|
|
value = 0;
|
|
break;
|
|
case 3:
|
|
value = argv[2];
|
|
break;
|
|
default:
|
|
return wool_error(BAD_NUMBER_OF_ARGS, argc);
|
|
}
|
|
|
|
must_be_namespace(argv[1], 1);
|
|
if (argv[0] -> type == WLAtom) {
|
|
if (!value && ((WOOL_Atom) argv[0]) -> c_val)
|
|
value = (WOOL_OBJECT)
|
|
WLQuotedExpr_make(((WOOL_Atom) argv[0]) -> c_val);
|
|
decrease_reference(((WOOL_Atom) argv[0]) -> c_val);
|
|
argv[0] -> type = WLName;
|
|
NameNamespace(((WOOL_Name) argv[0])) = ((WOOL_Namespace) argv[1]);
|
|
((WOOL_Name) argv[0]) -> index =
|
|
WLNamespace_add_name((WOOL_Namespace) argv[1]);
|
|
} else if (argv[0] -> type == WLName) {
|
|
if (NameNamespace(((WOOL_Name) argv[0])) !=
|
|
((WOOL_Namespace) argv[1])) {
|
|
WLName_release_values(argv[0]);
|
|
NameNamespace(((WOOL_Name) argv[0])) = ((WOOL_Namespace) argv[1]);
|
|
((WOOL_Name) argv[0]) -> index =
|
|
WLNamespace_add_name((WOOL_Namespace) argv[1]);
|
|
} else {
|
|
return argv[0];
|
|
}
|
|
} else
|
|
bad_argument(argv[0], 0, "symbol");
|
|
if (value) { /* set to arg */
|
|
WLName_set_all(argv[1], argv[0], value);
|
|
}
|
|
return argv[0];
|
|
}
|
|
|
|
/* manage active namespace
|
|
* (set-current-namespace namespace current)
|
|
* with current out-of-bounds (e.g -1) returning current one
|
|
*/
|
|
|
|
WOOL_OBJECT
|
|
WLNamespace_set_current(namespace, index)
|
|
WOOL_Namespace namespace;
|
|
WOOL_Number index;
|
|
{
|
|
must_be_namespace(namespace, 0);
|
|
must_be_number(index, 1);
|
|
if (index -> number >= 0 && index -> number < namespace -> number) {
|
|
namespace -> current = index -> number;
|
|
if (namespace -> trigger)
|
|
(*(namespace -> trigger))(index -> number);
|
|
return (WOOL_OBJECT) index;
|
|
} else {
|
|
return (WOOL_OBJECT) WLNumber_make(namespace -> current);
|
|
}
|
|
}
|
|
|
|
/* size of states in the namespace
|
|
*/
|
|
|
|
WOOL_OBJECT
|
|
WLNamespace_size(namespace)
|
|
WOOL_Namespace namespace;
|
|
{
|
|
must_be_namespace(namespace, 0);
|
|
return (WOOL_OBJECT) WLNumber_make(namespace -> number);
|
|
}
|
|
|
|
/* namespace-of:
|
|
* on a name returns namespace or NIL if global
|
|
*/
|
|
|
|
WOOL_OBJECT
|
|
WLName_namespace(name)
|
|
WOOL_Name name;
|
|
{
|
|
if (name -> type == WLAtom)
|
|
return NIL;
|
|
else if (name -> type == WLName)
|
|
return (WOOL_OBJECT) NameNamespace(name);
|
|
else
|
|
return bad_argument(name, 0, "symbol");
|
|
}
|
|
|
|
/* free all c_val values */
|
|
|
|
WLName_release_values(name)
|
|
WOOL_Name name;
|
|
{
|
|
WOOL_Namespace namespace = NameNamespace(name);
|
|
int i;
|
|
|
|
for (i = 0; i < namespace -> number; i++)
|
|
decrease_reference((namespace -> namespaces[i])[name -> index]);
|
|
}
|
|
|
|
WOOL_OBJECT
|
|
WLName_unbind(name)
|
|
WOOL_Name name;
|
|
{
|
|
WOOL_Namespace namespace = NameNamespace(name);
|
|
|
|
decrease_reference((namespace -> namespaces[namespace -> current])
|
|
[name -> index]);
|
|
(namespace -> namespaces[namespace -> current])
|
|
[name -> index] = UNDEFINED_WOOL_VALUE;
|
|
return NIL;
|
|
}
|
|
|
|
/* namespace methods */
|
|
|
|
WOOL_OBJECT
|
|
WLNamespace_print(obj)
|
|
WOOL_Namespace obj;
|
|
{
|
|
wool_printf("{NAMESPACE 0x%x ", obj);
|
|
wool_printf("(%d spaces", obj -> number);
|
|
wool_printf(" of %d names)}", obj -> size);
|
|
return (WOOL_OBJECT) obj;
|
|
}
|
|
|
|
WOOL_OBJECT
|
|
WLNamespace_free(namespace)
|
|
WOOL_Namespace namespace;
|
|
{
|
|
free(namespace);
|
|
return NULL;
|
|
}
|
|
|
|
/* name methods */
|
|
|
|
/*
|
|
* Evaluating an name returns the pointed slot
|
|
*/
|
|
|
|
WOOL_OBJECT
|
|
WLName_eval(name)
|
|
WOOL_Name name;
|
|
{
|
|
WOOL_Namespace namespace = NameNamespace(name);
|
|
WOOL_OBJECT value;
|
|
|
|
if ((value = ((namespace -> namespaces)[namespace -> current])
|
|
[name -> index]) != UNDEFINED_WOOL_VALUE)
|
|
return value;
|
|
else
|
|
return wool_error(UNDEFINED_VARIABLE, name -> p_name);
|
|
}
|
|
|
|
WOOL_OBJECT *
|
|
WLName_slot(name)
|
|
WOOL_Name name;
|
|
{
|
|
WOOL_Namespace namespace = NameNamespace(name);
|
|
|
|
return &(((namespace -> namespaces)[namespace -> current])[name -> index]);
|
|
}
|
|
|
|
WOOL_OBJECT
|
|
WLName_silent_eval(name)
|
|
WOOL_Name name;
|
|
{
|
|
WOOL_Namespace namespace = NameNamespace(name);
|
|
|
|
return ((namespace -> namespaces)[namespace -> current]) [name -> index];
|
|
}
|
|
|
|
WOOL_OBJECT
|
|
WLName_set(name, value)
|
|
WOOL_Name name;
|
|
WOOL_OBJECT value;
|
|
{
|
|
WOOL_OBJECT new = WOOL_send(WOOL_eval, value, (value));
|
|
WOOL_Namespace namespace = NameNamespace(name);
|
|
WOOL_OBJECT *value_ptr = &(((namespace -> namespaces)
|
|
[namespace -> current])[name -> index]);
|
|
|
|
decrease_reference(*value_ptr);
|
|
increase_reference(*value_ptr = new);
|
|
return new;
|
|
}
|
|
|
|
WOOL_OBJECT
|
|
WLName_setq(name, value)
|
|
WOOL_Name name;
|
|
WOOL_OBJECT value;
|
|
{
|
|
WOOL_Namespace namespace = NameNamespace(name);
|
|
WOOL_OBJECT *value_ptr = &(((namespace -> namespaces)
|
|
[namespace -> current])[name -> index]);
|
|
|
|
decrease_reference(*value_ptr);
|
|
increase_reference(*value_ptr = value);
|
|
return value;
|
|
}
|
|
|
|
/* like set but on all spaces */
|
|
|
|
WLName_set_all(namespace, name, value)
|
|
WOOL_Namespace namespace;
|
|
WOOL_Name name;
|
|
WOOL_OBJECT value;
|
|
{
|
|
WOOL_OBJECT *value_ptr;
|
|
int i, old_current = namespace -> current;
|
|
|
|
if (namespace -> save_state)
|
|
(*(namespace -> save_state)) ();
|
|
for (i = 0; i < namespace -> number; i++) {
|
|
value_ptr = &(((namespace -> namespaces)[i])[name -> index]);
|
|
decrease_reference(*value_ptr);
|
|
namespace -> current = i;
|
|
if (namespace -> trigger)
|
|
(*(namespace -> trigger)) (i);
|
|
increase_reference(*value_ptr = WOOL_send(WOOL_eval, value, (value)));
|
|
}
|
|
namespace -> current = old_current;
|
|
if (namespace -> trigger)
|
|
(*(namespace -> trigger)) (old_current);
|
|
if (namespace -> restore_state)
|
|
(*(namespace -> restore_state)) ();
|
|
}
|
|
|
|
/*
|
|
* WLName_execute:
|
|
* executes the object in the C_val
|
|
*/
|
|
|
|
WOOL_OBJECT
|
|
WLName_execute(name, list)
|
|
WOOL_Name name;
|
|
WOOL_List list;
|
|
{
|
|
WOOL_Namespace namespace = NameNamespace(name);
|
|
WOOL_OBJECT value = ((namespace -> namespaces)
|
|
[namespace -> current])[name -> index];
|
|
|
|
if (value != UNDEFINED_WOOL_VALUE && (value -> type != WLAtom)) {
|
|
return WOOL_send(WOOL_execute, value, (value, list));
|
|
} else if (value && (value == NIL)) {
|
|
return NIL;
|
|
} else {
|
|
return (wool_error(UNDEFINED_FUNCTION, name));
|
|
}
|
|
}
|