aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Initial data commit

Browse source
This commit is contained in:
Ingy döt Net 2023-07-01 11:58:00 -04:00
parent 72d218235f
commit f23f22d71c
199087 changed files with 3378941 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

195
Task/Memory-allocation/Tcl/memory-allocation-1.tcl Normal file
View file

@ -0,0 +1,195 @@
#include <tcl.h>
/* A data structure used to enforce data safety */
struct block {
int size;
unsigned char data[4];
};
static int
Memalloc(
ClientData clientData,
Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv)
{
Tcl_HashTable *nameMap = clientData;
static int nameCounter = 0;
char nameBuf[30];
Tcl_HashEntry *hPtr;
int size, dummy;
struct block *blockPtr;
/* Parse arguments */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "size");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[1], &size) != TCL_OK) {
return TCL_ERROR;
}
if (size < 1) {
Tcl_AppendResult(interp, "size must be positive", NULL);
return TCL_ERROR;
}
/* The ckalloc() function will panic on failure to allocate. */
blockPtr = (struct block *)
ckalloc(sizeof(struct block) + (unsigned) (size<4 ? 0 : size-4));
/* Set up block */
blockPtr->size = size;
memset(blockPtr->data, 0, blockPtr->size);
/* Give it a name and return the name */
sprintf(nameBuf, "block%d", nameCounter++);
hPtr = Tcl_CreateHashEntry(nameMap, nameBuf, &dummy);
Tcl_SetHashValue(hPtr, blockPtr);
Tcl_SetObjResult(interp, Tcl_NewStringObj(nameBuf, -1));
return TCL_OK;
}
static int
Memfree(
ClientData clientData,
Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv)
{
Tcl_HashTable *nameMap = clientData;
Tcl_HashEntry *hPtr;
struct block *blockPtr;
/* Parse the arguments */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "handle");
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(nameMap, Tcl_GetString(objv[1]));
if (hPtr == NULL) {
Tcl_AppendResult(interp, "unknown handle", NULL);
return TCL_ERROR;
}
blockPtr = Tcl_GetHashValue(hPtr);
/* Squelch the memory */
Tcl_DeleteHashEntry(hPtr);
ckfree((char *) blockPtr);
return TCL_OK;
}
static int
Memset(
ClientData clientData,
Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv)
{
Tcl_HashTable *nameMap = clientData;
Tcl_HashEntry *hPtr;
struct block *blockPtr;
int index, byte;
/* Parse the arguments */
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "handle index byte");
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(nameMap, Tcl_GetString(objv[1]));
if (hPtr == NULL) {
Tcl_AppendResult(interp, "unknown handle", NULL);
return TCL_ERROR;
}
blockPtr = Tcl_GetHashValue(hPtr);
if (Tcl_GetIntFromObj(interp, objv[2], &index) != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[3], &byte) != TCL_OK) {
return TCL_ERROR;
}
if (index < 0 || index >= blockPtr->size) {
Tcl_AppendResult(interp, "index out of range", NULL);
return TCL_ERROR;
}
/* Update the byte of the data block */
blockPtr->data[index] = (unsigned char) byte;
return TCL_OK;
}
static int
Memget(
ClientData clientData,
Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv)
{
Tcl_HashTable *nameMap = clientData;
Tcl_HashEntry *hPtr;
struct block *blockPtr;
int index, byte;
/* Parse the arguments */
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "handle index");
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(nameMap, Tcl_GetString(objv[1]));
if (hPtr == NULL) {
Tcl_AppendResult(interp, "unknown handle", NULL);
return TCL_ERROR;
}
blockPtr = Tcl_GetHashValue(hPtr);
if (Tcl_GetIntFromObj(interp, objv[2], &index) != TCL_OK) {
return TCL_ERROR;
}
if (index < 0 || index >= blockPtr->size) {
Tcl_AppendResult(interp, "index out of range", NULL);
return TCL_ERROR;
}
/* Read the byte from the data block and return it */
Tcl_SetObjResult(interp, Tcl_NewIntObj(blockPtr->data[index]));
return TCL_OK;
}
static int
Memaddr(
ClientData clientData,
Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv)
{
Tcl_HashTable *nameMap = clientData;
Tcl_HashEntry *hPtr;
struct block *blockPtr;
int addr;
/* Parse the arguments */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "handle");
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(nameMap, Tcl_GetString(objv[1]));
if (hPtr == NULL) {
Tcl_AppendResult(interp, "unknown handle", NULL);
return TCL_ERROR;
}
blockPtr = Tcl_GetHashValue(hPtr);
/* This next line is non-portable */
addr = (int) blockPtr->data;
Tcl_SetObjResult(interp, Tcl_NewIntObj(addr));
return TCL_OK;
}
int
Memalloc_Init(Tcl_Interp *interp)
{
/* Make the hash table */
Tcl_HashTable *hashPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hashPtr, TCL_STRING_KEYS);
/* Register the commands */
Tcl_CreateObjCommand(interp, "memalloc", Memalloc, hashPtr, NULL);
Tcl_CreateObjCommand(interp, "memfree", Memfree, hashPtr, NULL);
Tcl_CreateObjCommand(interp, "memset", Memset, hashPtr, NULL);
Tcl_CreateObjCommand(interp, "memget", Memget, hashPtr, NULL);
Tcl_CreateObjCommand(interp, "memaddr", Memaddr, hashPtr, NULL);
/* Register the package */
return Tcl_PkgProvide(interp, "memalloc", "1.0");
}

8
Task/Memory-allocation/Tcl/memory-allocation-2.tcl Normal file
View file

@ -0,0 +1,8 @@
package require memalloc
set block [memalloc 1000]
puts "allocated $block at [memaddr $block]"
memset $block 42 79
someOtherCommand [memaddr $block]
puts "$block\[42\] is now [memget $block 42]"
memfree $block