+++ /dev/null
-/**
- @file libsof.c
- @brief See header for details
- $Revision$
- $HeadURL$
- */
-#include "libsof.h"
-#include <stdint.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-
-static void libsof_read_header(FILE* file, sof_file_t* obj);
-static void libsof_read_symbols(FILE* file, sof_file_t* obj);
-static void libsof_read_strings(FILE* file, sof_file_t* obj);
-static void libsof_read_data(FILE* file, sof_file_t* obj);
-static void libsof_read_code(FILE* file, sof_file_t* obj);
-static void libsof_write_header(FILE* file, sof_file_t* obj);
-static void libsof_write_symbols(FILE* file, sof_file_t* obj);
-static void libsof_write_strings(FILE* file, sof_file_t* obj);
-static void libsof_write_data(FILE* file, sof_file_t* obj);
-static void libsof_write_code(FILE* file, sof_file_t* obj);
-static void* libsof_get_segment_addr(void* segment, size_t seg_size, size_t el_size, size_t offset);
-static size_t libsof_add_to_segment(void** segment, size_t* seg_size, void const* data, size_t length);
-
-/******************************************************************************
- * Functions for Reading an SOF file
- *****************************************************************************/
-sof_file_t* libsof_read_obj(char const* fname)
-{
- sof_file_t* obj = NULL;
- /* Open the file for reading */
- FILE* fhndl = fopen(fname,"rb");
- /* read the files contents if valid */
- if (fhndl)
- {
- /* Allocate space for the header and object structure */
- obj = (sof_file_t*)calloc(1,sizeof(sof_file_t));
- /* Read the contents of the file into memory */
- libsof_read_header(fhndl, obj);
- libsof_read_symbols(fhndl, obj);
- libsof_read_strings(fhndl, obj);
- libsof_read_data(fhndl, obj);
- libsof_read_code(fhndl, obj);
- }
- /* close the file and return the read object */
- fclose(fhndl);
- return obj;
-}
-
-static void libsof_read_header(FILE* file, sof_file_t* obj)
-{
- /* Read the object header out of the file */
- obj->header = (sof_header_t*)malloc(sizeof(sof_header_t));
- fread(obj->header, sizeof(sof_header_t), 1, file);
-}
-
-static void libsof_read_symbols(FILE* file, sof_file_t* obj)
-{
- if (obj->header->sym_tbl_sz)
- {
- obj->symbols = (sof_st_entry_t*)malloc( obj->header->sym_tbl_sz );
- fread(obj->symbols, sizeof(uint8_t), obj->header->sym_tbl_sz, file);
- }
-}
-
-static void libsof_read_strings(FILE* file, sof_file_t* obj)
-{
- if (obj->header->sym_str_tbl_sz)
- {
- obj->strings = (char*)malloc( obj->header->sym_str_tbl_sz );
- fread( obj->strings, sizeof(uint8_t), obj->header->sym_str_tbl_sz, file);
- }
-}
-
-static void libsof_read_data(FILE* file, sof_file_t* obj)
-{
- if (obj->header->data_sz)
- {
- obj->data = (uint8_t*)malloc( obj->header->data_sz );
- fread( obj->data, sizeof(uint8_t), obj->header->data_sz, file);
- }
-}
-
-static void libsof_read_code(FILE* file, sof_file_t* obj)
-{
- if (obj->header->code_sz)
- {
- obj->code = (uint32_t*)malloc( obj->header->code_sz );
- fread(obj->code, sizeof(uint8_t), obj->header->code_sz, file);
- }
-}
-
-/******************************************************************************
- * Functions for Writing an SOF file
- *****************************************************************************/
-bool libsof_write_obj(sof_file_t* obj, char const* fname)
-{
- bool ret = false;
- /* Open the file for reading */
- FILE* fhndl = fopen(fname,"wb");
- /* if the file was successfully opened */
- if (fhndl)
- {
- /* Write the contents of the file in sequence */
- libsof_write_header(fhndl,obj);
- libsof_write_symbols(fhndl,obj);
- libsof_write_strings(fhndl,obj);
- libsof_write_data(fhndl,obj);
- libsof_write_code(fhndl,obj);
- }
- /* close the file and return the read object */
- fclose(fhndl);
- return ret;
-}
-
-static void libsof_write_header(FILE* file, sof_file_t* obj)
-{
- fwrite(obj->header, sizeof(sof_header_t), 1, file);
-}
-
-static void libsof_write_symbols(FILE* file, sof_file_t* obj)
-{
- if (obj->header->sym_tbl_sz)
- {
- fwrite(obj->symbols, sizeof(sof_st_entry_t), obj->header->sym_tbl_sz / sizeof(sof_st_entry_t), file);
- }
-}
-
-static void libsof_write_strings(FILE* file, sof_file_t* obj)
-{
- if (obj->header->sym_str_tbl_sz)
- {
- fwrite( obj->strings, sizeof(uint8_t), obj->header->sym_str_tbl_sz, file);
- }
-}
-
-static void libsof_write_data(FILE* file, sof_file_t* obj)
-{
- if (obj->header->data_sz)
- {
- fwrite( obj->data, sizeof(uint8_t), obj->header->data_sz, file);
- }
-}
-
-static void libsof_write_code(FILE* file, sof_file_t* obj)
-{
- if (obj->header->code_sz)
- {
- fwrite(obj->code, sizeof(uint32_t), obj->header->code_sz / sizeof(uint32_t), file);
- }
-}
-
-/******************************************************************************
- * Functions for Creating and Modifying SOF files
- *****************************************************************************/
-sof_file_t* libsof_new_obj(void)
-{
- sof_file_t* obj = (sof_file_t*)calloc(1,sizeof(sof_file_t));
- obj->header = (sof_header_t*)calloc(1,sizeof(sof_header_t));
- obj->header->version = SOF_VERSION;
- return obj;
-}
-
-void libsof_free_obj(sof_file_t* obj)
-{
- free(obj->header);
- free(obj->symbols);
- free(obj->strings);
- free(obj->data);
- free(obj->code);
- free(obj);
-}
-
-size_t libsof_get_symbol_table_size(sof_file_t* obj)
-{
- return obj->header->sym_tbl_sz;
-}
-
-size_t libsof_get_string_table_size(sof_file_t* obj)
-{
- return obj->header->sym_str_tbl_sz;
-}
-
-size_t libsof_get_data_segment_size(sof_file_t* obj)
-{
- return obj->header->data_sz;
-}
-
-size_t libsof_get_code_segment_size(sof_file_t* obj)
-{
- return obj->header->code_sz;
-}
-
-size_t libsof_get_num_symbols(sof_file_t* obj)
-{
- return obj->header->sym_tbl_sz / sizeof(sof_st_entry_t);
-}
-
-size_t libsof_add_symbol(sof_file_t* obj, const char* name, uint32_t value, uint32_t size, uint32_t info)
-{
- size_t str_idx = libsof_add_string(obj, name);
- return libsof_add_st_entry(obj, str_idx, value, size, info);
-}
-
-size_t libsof_add_st_entry(sof_file_t* obj, uint32_t name, uint32_t value, uint32_t size, uint32_t info)
-{
- sof_st_entry_t new_sym = { name, value, size, info };
- return libsof_add_to_segment( (void**)&(obj->symbols), (size_t*)&(obj->header->sym_tbl_sz), &new_sym, sizeof(sof_st_entry_t) );
-}
-
-sof_st_entry_t const* libsof_get_st_entry(sof_file_t* obj, size_t offset)
-{
- return libsof_get_segment_addr( obj->symbols, obj->header->sym_tbl_sz, sizeof(sof_st_entry_t), offset);
-}
-
-size_t libsof_add_string(sof_file_t* obj, char const* name)
-{
- return libsof_add_to_segment( (void**)&(obj->strings), (size_t*)&(obj->header->sym_str_tbl_sz), name, strlen(name) + 1 );
-}
-
-char const* libsof_get_string(sof_file_t* obj, size_t offset)
-{
- return libsof_get_segment_addr( obj->strings, obj->header->sym_str_tbl_sz, sizeof(char), offset);
-}
-
-size_t libsof_add_data(sof_file_t* obj, uint8_t const* data, size_t length)
-{
- return libsof_add_to_segment( (void**)&(obj->data), (size_t*)&(obj->header->data_sz), data, length );
-}
-
-uint8_t const* libsof_get_data(sof_file_t* obj, size_t offset)
-{
- return libsof_get_segment_addr( obj->data, obj->header->data_sz, sizeof(uint8_t), offset);
-}
-
-size_t libsof_add_code(sof_file_t* obj, uint32_t const* code, size_t length)
-{
- return libsof_add_to_segment( (void**)&(obj->code), (size_t*)&(obj->header->code_sz), code, length * sizeof(uint32_t) );
-}
-
-uint32_t const* libsof_get_code(sof_file_t* obj, size_t offset)
-{
- return libsof_get_segment_addr( obj->code, obj->header->code_sz, sizeof(uint32_t), offset);
-}
-
-/******************************************************************************
- * Static Helper Functions
- *****************************************************************************/
-static void* libsof_get_segment_addr(void* segment, size_t seg_size, size_t el_size, size_t offset)
-{
- void* addr = NULL;
- size_t addr_offset = offset * el_size;
- if (addr_offset < seg_size)
- {
- addr = segment + addr_offset;
- }
- return addr;
-}
-
-static size_t libsof_add_to_segment(void** segment, size_t* seg_size, void const* data, size_t length)
-{
- size_t offset = *(seg_size);
- *(seg_size) = offset + length;
- *(segment) = realloc(*(segment), *(seg_size));
- memcpy( *(segment) + offset, data, length );
- return offset;
-}
-
+++ /dev/null
-/**\r
- @file libsof.h\r
- @brief TODO: Describe this file\r
- $Revision$\r
- $HeadURL$\r
- */\r
-#ifndef LIBSOF_H\r
-#define LIBSOF_H\r
-\r
-#include "sof.h"\r
-#include <stdbool.h>\r
-#include <stdint.h>\r
-#include <stddef.h>\r
-\r
-typedef struct {\r
- sof_header_t* header;\r
- sof_st_entry_t* symbols;\r
- char* strings;\r
- uint8_t* data;\r
- uint32_t* code;\r
-} sof_file_t;\r
-\r
-sof_file_t* libsof_read_obj(char const* fname);\r
-bool libsof_write_obj(sof_file_t* obj, char const* fname);\r
-sof_file_t* libsof_new_obj(void);\r
-void libsof_free_obj(sof_file_t* obj);\r
-size_t libsof_get_symbol_table_size(sof_file_t* obj);\r
-size_t libsof_get_string_table_size(sof_file_t* obj);\r
-size_t libsof_get_data_segment_size(sof_file_t* obj);\r
-size_t libsof_get_code_segment_size(sof_file_t* obj);\r
-size_t libsof_get_num_symbols(sof_file_t* obj);\r
-size_t libsof_add_symbol(sof_file_t* obj, const char* name, uint32_t value, uint32_t size, uint32_t info);\r
-size_t libsof_add_st_entry(sof_file_t* obj, uint32_t name, uint32_t value, uint32_t size, uint32_t info);\r
-sof_st_entry_t const* libsof_get_st_entry(sof_file_t* obj, size_t offset);\r
-size_t libsof_add_string(sof_file_t* obj, char const* name);\r
-char const* libsof_get_string(sof_file_t* obj, size_t offset);\r
-size_t libsof_add_data(sof_file_t* obj, uint8_t const* data, size_t length);\r
-uint8_t const* libsof_get_data(sof_file_t* obj, size_t offset);\r
-size_t libsof_add_code(sof_file_t* obj, uint32_t const* code, size_t length);\r
-uint32_t const* libsof_get_code(sof_file_t* obj, size_t offset);\r
-\r
-#endif /* LIBSOF_H */\r
+++ /dev/null
-/**\r
- @file sof.h\r
- @brief TODO: Describe this file\r
- $Revision$\r
- $HeadURL$\r
- */\r
-#ifndef SOF_H\r
-#define SOF_H\r
-\r
-#include <stdint.h>\r
-\r
-/*\r
- SCLPL Object File Layout\r
-\r
- -----------------------\r
- | SOF Header |\r
- -----------------------\r
- | Symbol Table |\r
- -----------------------\r
- | Symbol String Table |\r
- -----------------------\r
- | Data Segment |\r
- -----------------------\r
- | Code Segment |\r
- -----------------------\r
-\r
-*/\r
-\r
-/* Macro for generating a 32-bit date code based on year, month, and day */\r
-#define DATE_CODE(year,month,day) (year << 16) | (month << 8) | (day)\r
-\r
-/* The version of the SOF format supported by this library represented as a\r
- * 32-bit date code */\r
-#define SOF_VERSION DATE_CODE(2013,9,10)\r
-\r
-/* Definition of the SOF file header. The header appears at the beginning of any\r
- * SOF file and contains information about the SOF version of the file and the\r
- * sizes of each section in the file. */\r
-typedef struct {\r
- /* 32-bit date code representing the version of SOF format used by the file */\r
- uint32_t version;\r
- /* This size of the symbol table in bytes. A value of 0 indicates that the\r
- * symbol table segment has been omitted from the file */\r
- uint32_t sym_tbl_sz;\r
- /* The size of the symbol string table segment in bytes. Each entry in the\r
- * symbol string table consists of an array of bytes terminated by a NULL\r
- * byte (0x00). */\r
- uint32_t sym_str_tbl_sz;\r
- /* The size in bytes of the constant data segment. This segment contains\r
- * constant data that is referenced by the code segment. */\r
- uint32_t data_sz;\r
- /* The size of the code segment in bytes. Each instruction is represented by\r
- * a 32-bit value and represents a single action to be performed by the\r
- * bytecode interpreter. */\r
- uint32_t code_sz;\r
-} sof_header_t;\r
-\r
-/* Definition of the SOF symbol table entry */\r
-typedef struct {\r
- /* Offset into the string section where the string for the symbol is\r
- * located */\r
- uint32_t name;\r
- uint32_t value;\r
- uint32_t size;\r
- uint32_t info;\r
-} sof_st_entry_t;\r
-\r
-#endif /* SOF_H */\r
+++ /dev/null
-#include <stdio.h>\r
-#include <libsof.h>\r
-\r
-#define GET_VERSION_YEAR(version) (version >> 16)\r
-#define GET_VERSION_MONTH(version) ((version >> 8) & 0xFF)\r
-#define GET_VERSION_DAY(version) (version & 0xFF)\r
-\r
-void print_obj(sof_file_t* obj);\r
-void print_hex(char const* header, uint8_t const* buffer, size_t length);\r
-\r
-void create_obj_file(char* fname)\r
-{\r
- sof_file_t* obj = libsof_new_obj();\r
-\r
- libsof_add_symbol(obj, "foo", 0x11223344, 0x22222222, 0x33333333);\r
-\r
- uint8_t data[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 };\r
- libsof_add_data(obj, data, 16);\r
- libsof_add_data(obj, data, 16);\r
- libsof_add_data(obj, data, 16);\r
-\r
- uint32_t code[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 };\r
- libsof_add_code(obj, code, 16);\r
- libsof_add_code(obj, code, 16);\r
- libsof_add_code(obj, code, 16);\r
-\r
- libsof_write_obj(obj,fname);\r
- libsof_free_obj(obj);\r
-}\r
-\r
-void print_obj(sof_file_t* obj)\r
-{\r
- /* print header metadata */\r
- printf("SOF Version:\t%#x (%d/%d/%d)\n",\r
- obj->header->version,\r
- GET_VERSION_DAY(obj->header->version),\r
- GET_VERSION_MONTH(obj->header->version),\r
- GET_VERSION_YEAR(obj->header->version));\r
- printf("Symbol Table:\t%d bytes\n", obj->header->sym_tbl_sz);\r
- printf("String Table:\t%d bytes\n", obj->header->sym_str_tbl_sz);\r
- printf("Data Size:\t%d bytes\n", obj->header->data_sz);\r
- printf("Code Size:\t%d bytes\n", obj->header->code_sz);\r
-\r
- /* print symbol table */\r
- printf("\nIndex\tValue\t\tSize\t\tInfo\t\tName\n");\r
- for(size_t i = 0; i < libsof_get_num_symbols(obj); i++)\r
- {\r
- sof_st_entry_t const* symbol = libsof_get_st_entry(obj,i);\r
- char const* name = libsof_get_string(obj,symbol->name);\r
- printf("[%d]\t%#x\t%#x\t%#x\t%s\n", i, symbol->value, symbol->size, symbol->info, name);\r
- }\r
-\r
- /* print segments as hex listing */\r
- print_hex("Data Segment", (uint8_t const *)libsof_get_data(obj,0), libsof_get_data_segment_size(obj));\r
- print_hex("Code Segment", (uint8_t const *)libsof_get_code(obj,0), libsof_get_code_segment_size(obj));\r
-}\r
-\r
-void print_hex(char const* header, uint8_t const* buffer, size_t length)\r
-{\r
- printf("\n\n%s\n",header);\r
- printf("----------------------------------------------------------");\r
- for(size_t i = 0; i < length; i++)\r
- {\r
- if ((i%16) == 0)\r
- {\r
- printf("\n0x%04x\t", i);\r
- }\r
- else if ((i%4) == 0)\r
- {\r
- printf(" ");\r
- }\r
- printf("%02x ", buffer[i]);\r
- }\r
-}\r
-\r
-int main(int argc, char** argv)\r
-{\r
- if (argc == 1)\r
- {\r
- printf("%s: no input files.\n", argv[0]);\r
- }\r
- else\r
- {\r
- create_obj_file(argv[1]);\r
- for (uint32_t i = 1; i < argc; i++)\r
- {\r
- printf("\nFilename:\t%s\n", argv[i]);\r
- sof_file_t* obj = libsof_read_obj(argv[i]);\r
- print_obj(obj);\r
- libsof_free_obj(obj);\r
- }\r
- }\r
-}\r
-\r
+++ /dev/null
-#include <stdlib.h>
-#include <stdbool.h>
-#include <setjmp.h>
-#include <setjmp.h>
-#include "gc.h"
-
-/*****************************************************************************/
-void* p_Stack_Base = NULL;
-block_t* p_Blocks = NULL;
-size_t Bytes_Allocated = 0;
-
-/*****************************************************************************/
-void gc_set_stack_base(void* stack_base)
-{
- p_Stack_Base = stack_base;
-}
-
-void* gc_allocate(size_t num_bytes)
-{
- /* If we need to, then trigger a collection */
- if (Bytes_Allocated >= (1024 * 1024)/* 1 MB */)
- gc_collect();
-
- /* Allocate the block */
- size_t alloc_sz = gc_total_alloc_size(num_bytes);
- block_t* p_block = (block_t*) malloc( alloc_sz );
-
- /* Set the metadata */
- Bytes_Allocated += alloc_sz;
- p_block->hdr.size = alloc_sz - sizeof(header_t);
- p_block->hdr.next = p_Blocks;
- p_Blocks = p_block;
-
- /* Return the data portion */
- return &(p_block->data[0]);
-}
-
-void gc_shutdown(void)
-{
- gc_free_blocks(p_Blocks);
-}
-
-void gc_collect(void)
-{
- if (NULL != p_Stack_Base)
- {
- block_t* p_grey = gc_scan_stack();
- block_t* p_black = NULL;
- Bytes_Allocated = 0;
-
- while(p_grey != NULL)
- {
- /* Remove the block from the grey list */
- block_t* p_block = p_grey;
- p_grey = p_grey->hdr.next;
-
- /* add it to the black list */
- p_block->hdr.next = p_black;
- p_black = p_block;
-
- /* scan the block for more objects */
- p_grey = gc_scan_block(p_block,p_grey);
- }
-
- /* Reclaim all unused blocks */
- gc_free_blocks(p_Blocks);
- p_Blocks = p_black;
- }
-}
-
-size_t gc_total_alloc_size(size_t size)
-{
- /* Get the total number of bytes to allocate (including block metadata) */
- size_t req_size = sizeof(header_t) + size;
- /* Align to a machine word boundary. 4 bytes on 32-bit, 8 bytes on 64-bit */
- size_t align = (sizeof(long) - (req_size % sizeof(long)));
- align = (align == sizeof(long)) ? 0 : align;
- req_size = req_size + align;
- return req_size;
-}
-
-block_t* gc_scan_stack(void)
-{
- jmp_buf registers;
- void** stack_top;
- void** stack_btm;
- block_t* p_roots = NULL;
-
- /* Figure out which direction the stack grows and set the pointers accordingly */
- stack_btm = ((p_Stack_Base < (void*)&stack_top) ? p_Stack_Base : &stack_top);
- stack_top = ((p_Stack_Base < (void*)&stack_top) ? &stack_top : p_Stack_Base);
-
- /* Copy register info to the stack */
- (void)setjmp( registers );
-
- /* scan the stack for pointers */
- while (stack_btm < stack_top)
- {
- /* Search the block list for a the block referenced */
- block_t* p_block = gc_find_block( stack_btm[0] );
-
- /* If we found a valid pointer */
- if (p_block != NULL)
- {
- /* The block is a root */
- p_block->hdr.next = p_roots;
- p_roots = p_block;
- }
-
- /* continue */
- stack_btm++;
- }
-
- return p_roots;
-}
-
-block_t* gc_scan_block(block_t* p_block, block_t* p_grey)
-{
- size_t index = p_block->hdr.size / sizeof(long);
- for (index; index > 0; index--)
- {
- void* ptr = (void*)(p_block->data[index]);
- block_t* p_block = gc_find_block( ptr );
- if (p_block != NULL)
- {
- p_block->hdr.next = p_grey;
- p_grey = p_block;
- break;
- }
- }
- return p_grey;
-}
-
-block_t* gc_find_block(void* addr)
-{
- block_t* p_block = NULL;
- block_t* p_prev = NULL;
- block_t* p_curr = p_Blocks;
- while (p_curr != NULL)
- {
- if (p_curr->data == addr)
- {
- p_block = p_curr;
- /* If the block is at the head of the list */
- if (p_prev == NULL)
- {
- p_prev = p_block->hdr.next;
- p_Blocks = p_prev;
- }
- /* Else its somewhere in the list */
- else
- {
- p_prev->hdr.next = p_block->hdr.next;
- }
- /* Clear the blocks next pointer */
- p_block->hdr.next = NULL;
- break;
- }
- p_prev = p_curr;
- p_curr = p_curr->hdr.next;
- }
- return p_block;
-}
-
-void gc_free_blocks(block_t* p_blocks)
-{
- while (p_blocks != NULL)
- {
- block_t* p_block = p_blocks;
- p_blocks = p_blocks->hdr.next;
- free(p_block);
- }
-}
-
-/*****************************************************************************/
-#if 0
-#include <stdio.h>
-#include <time.h>
-
-int main(int argc, char** argv)
-{
- /* Give the garbage collector a pointer to the base of our stack */
- int stack_base = 0;
- gc_set_stack_base(&stack_base);
-
- /* setup test variables */
- #define STACK_REF_ARRY_SZ 20
- int stack_ref_idx = 0;
- void* stack_refs[ STACK_REF_ARRY_SZ ] = { 0u };
-
- /* Generate some random block allocation requests */
- srand(time(NULL));
- while(true)
- {
- size_t size = rand();
- void* new_obj = gc_allocate( size );
- if (0 == (rand() % 2))
- {
- stack_refs[ stack_ref_idx % STACK_REF_ARRY_SZ ] = new_obj;
- stack_ref_idx++;
- }
- (void)stack_refs;
- }
-
- return 0;
-}
-#endif
-
+++ /dev/null
-/**
- @file gc.h
- @brief Public interface for the garbage collector.
- $Revision$
- $HeadURL$
-*/
-#ifndef GC_H
-#define GC_H
-
-#include <stdlib.h>
-
-typedef struct {
- void* next;
- size_t size;
-} header_t;
-
-typedef struct {
- header_t hdr;
- long data[1];
-} block_t;
-
-void gc_set_stack_base(void* stack_base);
-void* gc_allocate(size_t num_bytes);
-void gc_shutdown(void);
-static void gc_collect(void);
-static size_t gc_total_alloc_size(size_t size);
-static block_t* gc_scan_stack(void);
-static block_t* gc_scan_block(block_t* p_block, block_t* p_grey);
-static block_t* gc_find_block(void* addr);
-static void gc_free_blocks(block_t* p_blocks);
-
-#endif /* GC_H */
+++ /dev/null
-/**
- @file types.c
- @brief See header for details
- $Revision$
- $HeadURL$
-*/
-#include "types.h"
-//#include "gc.h"
-
-var_t new_num(double val)
-{
- /* Allocate the space */
- num_t* number = (num_t*)gc_allocate( sizeof(num_t) );
- /* Populate header info */
- /* Populate data */
- number->data = val;
- /* return the object */
- return (var_t)number;
-}
-
-var_t new_cell(var_t first, var_t rest)
-{
- /* Allocate the space */
- cell_t* cell = (cell_t*)gc_allocate( sizeof(cell_t) );
- /* Populate header info */
- /* Populate data */
- cell->first = first;
- cell->rest = rest;
- /* return the object */
- return (var_t)cell;
-}
-
-var_t new_char(uint32_t val)
-{
- /* Allocate the space */
- char_t* character = (char_t*)gc_allocate( sizeof(char_t) );
- /* Populate header info */
- /* Populate data */
- character->data = val;
- /* return the object */
- return (var_t)character;
-}
-
+++ /dev/null
-/**
- @file types.h
- @brief TODO: Describe this file
- $Revision$
- $HeadURL$
-*/
-#ifndef TYPES_H
-#define TYPES_H
-
-#include <stdbool.h>
-#include <stdint.h>
-
-typedef struct {
- long info;
-} header_t;
-
-typedef struct {
- header_t header;
- long data[1];
-} object_t;
-
-typedef const object_t* var_t;
-
-typedef struct {
- header_t header;
- double data;
-} num_t;
-
-var_t new_num(double val);
-
-typedef struct {
- header_t header;
- var_t first;
- var_t rest;
-} cell_t;
-
-var_t new_cell(var_t first, var_t rest);
-
-typedef struct {
- header_t header;
- uint32_t data;
-} char_t;
-
-var_t new_char(uint32_t val);
-
-//extern var_t True;
-//extern var_t False;
-
-#endif /* TYPES_H */
+++ /dev/null
-(declare (uses library))\r
-\r
-(define usage\r
-"\nUsage: slas <INFILE> <OUTFILE>\r
-\r
-Assemble <INFILE> to SCLPL bytecode and write the result to <OUTFILE>.\n")\r
-\r
-; Control Routines\r
-;------------------------------------------------------------------------------\r
-(define (assemble-file infile outfile)\r
- (define iprt (open-input-file infile))\r
- (define oprt (open-output-file outfile))\r
- (generate-bytecode iprt oprt))\r
-\r
-(define (generate-bytecode iprt oprt) '())\r
-\r
-; Main routine\r
-;------------------------------------------------------------------------------\r
-(if (= 2 (length (command-line-arguments)))\r
- (apply assemble-file (command-line-arguments))\r
- (print usage))\r
-(exit)\r
+++ /dev/null
-(declare (uses posix))\r
-(use posix)\r
-\r
-; Task Definition and Interaction\r
-;------------------------------------------------------------------------------\r
-(define-record task name desc active? deps actions)\r
-\r
-(define top-level-tasks '())\r
-\r
-(define current-namespace\r
- (make-parameter '()))\r
-\r
-(define current-desc\r
- (make-parameter #f))\r
-\r
-(define (task-register! task)\r
- (define name (task-name task))\r
- (define entry (assoc name top-level-tasks))\r
- (if (not entry)\r
- (set! top-level-tasks (cons (cons name task) top-level-tasks))\r
- (set-cdr! entry (task-merge (cdr entry) task))))\r
-\r
-(define (task-merge task1 task2)\r
- (make-task (task-name task1) (task-desc task1) #t\r
- (append (task-deps task1)\r
- (task-deps task2))\r
- (append (task-actions task1)\r
- (task-actions task2))))\r
-\r
-(define (task-lookup name)\r
- (define entry (assoc name top-level-tasks))\r
- (if (not entry)\r
- (error (string-append "No such task: " name))\r
- (cdr entry)))\r
-\r
-(define (task-invoke! name)\r
- (define task (task-lookup name))\r
- (if (task-active? task)\r
- (begin (task-active?-set! task #f)\r
- (map task-invoke! (task-deps task))\r
- (map (lambda (fn) (fn)) (task-actions task)))))\r
-\r
-(define (gen-task-name name)\r
- (define namespace (current-namespace))\r
- (if (not (null? namespace))\r
- (string-append namespace ":" name)\r
- name))\r
-\r
-; Environment Functions\r
-;------------------------------------------------------------------------------\r
-(define-record builder defaults action)\r
-\r
-(define (get-sys-env)\r
- (get-environment-variables))\r
-\r
-(define (set-sys-env! newenv)\r
- (clear-sys-env!)\r
- (map (lambda (p) (setenv (car p) (cdr p)))\r
- newenv))\r
-\r
-(define (clear-sys-env!)\r
- (map (lambda (p) (unsetenv (car p)))\r
- (get-environment-variables)))\r
-\r
-(define current-env\r
- (let [(curr-env (get-sys-env))]\r
- (lambda args\r
- (if (> (length args) 0)\r
- (begin (set-sys-env! (car args))\r
- (set! curr-env (car args)))\r
- curr-env))))\r
-\r
-(define (env-clone env . vars)\r
- (define newenv (map (lambda (p) (cons (car p) (cdr p))) env))\r
- (define newvals '())\r
- (map (lambda (e)\r
- (define entry (assoc (car e) newenv))\r
- (if entry\r
- (set-cdr! entry (cdr e))\r
- (set! newvals (cons e newvals))))\r
- vars)\r
- (append newvals newenv))\r
-\r
-(define (env-get env key)\r
- (define entry (assoc key env))\r
- (if entry (cdr entry) #f))\r
-\r
-(define (env-set env key value)\r
- (cons (cons key value)\r
- (env-unset env key)))\r
-\r
-(define (env-unset env key)\r
- (cond [(null? env) '()]\r
- [(string=? (caar env) key) (env-unset (cdr env) key)]\r
- [else (cons (car env) (env-unset (cdr env) key))]))\r
-\r
-(define (env-extend env . vars)\r
- (foldl (lambda (env p)\r
- (env-set env (car p) (cdr p)))\r
- env\r
- vars))\r
-\r
-(define (env-substitute env str)\r
- (list->string (sub-vars (string->list str) env)))\r
-\r
-(define (env-prepend-path env path)\r
- '())\r
-\r
-(define (env-append-path env path)\r
- '())\r
-\r
-(define (env-add-builders env . builders)\r
- '())\r
-\r
-; Builders\r
-;------------------------------------------------------------------------------\r
-\r
-\r
-; System Utility Functions\r
-;------------------------------------------------------------------------------\r
-(define verbose #f)\r
-\r
-(define (build type . args)\r
- (define bldr (assoc type (assoc "builders" (current-env))))\r
- (define bldr-env (env-merge (builder-defaults bldr) (current-env)))\r
- (apply (builder-action bldr) (cons bldr-env args)))\r
-\r
-(define (run . args)\r
- (define cmd (env-substitute (current-env) (string-join args " ")))\r
- (if verbose (print cmd))\r
- (if (not (= 0 (system cmd)))\r
- (fail-build cmd)))\r
-\r
-(define (fail-build cmd)\r
- (print "Error: Command returned a non-zero status")\r
- (exit 1))\r
-\r
-; Directories\r
-(define cd change-directory)\r
-(define curdir current-directory)\r
-(define mkdir create-directory)\r
-(define rmdir delete-directory)\r
-(define lsdir directory)\r
-(define dir? directory?)\r
-; glob\r
-\r
-; Files\r
-(define cp '())\r
-(define mv '())\r
-(define rm delete-file)\r
-\r
-; String Templating\r
-;------------------------------------------------------------------------------\r
-(define (sub-vars chlst env)\r
- (cond [(null? chlst) '()]\r
- [(char=? #\$ (car chlst)) (let [(pair (replace-var (cdr chlst) env))]\r
- (append (string->list (car pair))\r
- (sub-vars (cdr pair) env)))]\r
- [else (cons (car chlst) (sub-vars (cdr chlst) env))]))\r
-\r
-(define (replace-var chlst env)\r
- (define tok '())\r
- (define (collect-var-chars chlst)\r
- (if (or (null? chlst) (char=? (car chlst) #\space))\r
- (set! tok (cons (list->string (reverse tok)) chlst))\r
- (begin (set! tok (cons (car chlst) tok))\r
- (collect-var-chars (cdr chlst)))))\r
- (collect-var-chars chlst)\r
- (let [(var (env-get env (car tok)))]\r
- (if var\r
- (cons var (cdr tok))\r
- (cons "" (cdr tok)))))\r
-\r
-;(define (scan-tok chlst tok)\r
-; (cond [(or (null? chlst) (char=? #\space (car chlst)))\r
-; (list->string (reverse tok))]\r
-\r
-; System Utility Functions\r
-;------------------------------------------------------------------------------\r
-(define (string-join strlst jstr)\r
- (foldl (lambda (a b) (string-append a b jstr)) "" strlst))\r
-\r
-; DSL Definition\r
-;------------------------------------------------------------------------------\r
-(define-syntax task\r
- (syntax-rules (=>)\r
- [(_ name => (deps ...))\r
- (task-register! (make-task (gen-task-name name) (current-desc) #t '(deps ...) '()))]\r
- [(_ name => (deps ...) exp1 expn ...)\r
- (task-register!\r
- (make-task (gen-task-name name) (current-desc) #t '(deps ...)\r
- (list (lambda () exp1 expn ...))))]\r
- [(_ name exp1 expn ...)\r
- (task-register!\r
- (make-task (gen-task-name name) (current-desc) #t '()\r
- (list (lambda () exp1 expn ...))))]))\r
-\r
-(define-syntax namespace\r
- (syntax-rules ()\r
- [(_ name body ...)\r
- (let [(prev-ns (current-namespace))]\r
- (current-namespace (gen-task-name name))\r
- body ...\r
- (current-namespace prev-ns))]))\r
-\r
-(define (desc str)\r
- (current-desc str))\r
-\r
-(define-syntax environment\r
- (syntax-rules (<=)\r
- [(_ name <= parent vars ...)\r
- (define name (env-extend parent vars ...))]\r
- [(_ name vars ...)\r
- (define name (env-extend (current-env) vars ...))]))\r
-\r
-(define-syntax builder\r
- (syntax-rules (defaults action)\r
- [(_ (defaults vars ...) (action args body ...))\r
- (make-builder '(vars ...) (lambda args body ...))]))\r
-\r
-; Core Tasks\r
-;------------------------------------------------------------------------------\r
-(task "verbose"\r
- (set! verbose #t))\r
-\r
-(task "help"\r
- (map (lambda (t)\r
- (if (task-desc (cdr t))\r
- (print (string-append (task-name (cdr t)) " - " (task-desc (cdr t))))))\r
- top-level-tasks))\r
-; Main\r
-;------------------------------------------------------------------------------\r
-(define (run-top-level-tasks!)\r
- (map task-invoke!\r
- (if (= 0 (length (command-line-arguments)))\r
- '("default")\r
- (command-line-arguments))))\r
-\r
-(load "Spadefile")\r
-(run-top-level-tasks!)\r
-\r
+++ /dev/null
-; Regex Matching Macro\r
-;------------------------------------------------------------------------------\r
-(use regex ports extras)\r
-\r
-(define-syntax regex-case\r
- (syntax-rules (else)\r
- ((_ item (else result1 result2 ...))\r
- (begin result1 result2 ...))\r
-\r
- ((_ item (regex result1 result2 ...))\r
- (if (string-match regex item) (begin result1 result2 ...)))\r
-\r
- ((_ item (regex result1 result2 ...) clause1 clause2 ...)\r
- (if (string-match regex item)\r
- (begin result1 result2 ...)\r
- (regex-case item clause1 clause2 ...)))))\r
-\r
-; Reader Phase\r
-;------------------------------------------------------------------------------\r
-; This phase is responsible reading input from a port and constructing the\r
-; expression that the input represents.\r
-\r
-(define (sclpl-read port)\r
- (let [(tok (read-token port))]\r
- (if (eof-object? tok)\r
- tok\r
- (cond [(list-op? tok) (read-sexp port (get-sexp-term tok))]\r
- [(equal? "'" tok) `(quote ,(sclpl-read port))]\r
- [(equal? "`" tok) `(quasiquote ,(sclpl-read port))]\r
- [else (classify-atom tok)]))))\r
-\r
-(define (read-sexp port term)\r
- (define expr (sclpl-read port))\r
- (cond [(equal? expr term) '()]\r
- [(wrong-term? expr term) (error "Incorrectly matched list terminator")]\r
- [(equal? '|.| expr) (read-and-term port term)]\r
- [else (cons expr (read-sexp port term))]))\r
-\r
-\r
-(define (read-and-term port term)\r
- (define val (sclpl-read port))\r
- (define tval (sclpl-read port))\r
- (cond [(member val '(#\) #\] #\})) (error "")]\r
- [(equal? tval term) val]\r
- [(wrong-term? tval term) (error "")]\r
- [else (error "")]))\r
-\r
-(define (classify-atom atom)\r
- (regex-case atom\r
- ["nil" '()]\r
- ["true" #t]\r
- ["false" #f]\r
- ["^\".*\"$" (dequote atom)]\r
- ["^\\\\.+" (atom->char atom)]\r
- ["[{[()\\]}]" (string-ref atom 0)]\r
- ["#[dbox](#[ie])?.+" (or (string->number atom) (string->symbol atom))]\r
- ["[+-]?[0-9].*" (or (string->number atom) (string->symbol atom))]\r
- [else (if (string-literal? atom)\r
- (dequote atom)\r
- (string->symbol atom))]))\r
-\r
-(define (list-op? tok)\r
- (member (string-ref tok 0) '(#\( #\[ #\{)))\r
-\r
-(define (get-sexp-term tok)\r
- (define pairs '((#\( . #\)) (#\[ . #\]) (#\{ . #\})))\r
- (define term (assv (string-ref tok 0) pairs))\r
- (if term (cdr term) (error "Not a valid s-expression delimiter")))\r
-\r
-(define (wrong-term? expr term)\r
- (define terms '(#\) #\] #\}))\r
- (and (not (equal? expr term))\r
- (member expr terms)))\r
-\r
-(define (string-literal? atom)\r
- (and (char=? #\" (string-ref atom 0))\r
- (char=? #\" (string-ref atom (- (string-length atom) 1)))))\r
-\r
-(define (dequote str)\r
- (substring str 1 (- (string-length str) 1)))\r
-\r
-(define (atom->char atom)\r
- (define ch-name (substring atom 1))\r
- (define ch (if (= 1 (string-length ch-name))\r
- (string-ref ch-name 0)\r
- (char-name (string->symbol ch-name))))\r
- (or ch (error (string-append "Invalid character name: " ch-name))))\r
-\r
-;------------------------------------------------------------------------------\r
-\r
-(define whitespace (string->list " \t\r\n"))\r
-(define punctuation (string->list "()[]{}'`:,"))\r
-(define delimiters (string->list "()[]{}'`:,; \t\r\n"))\r
-(define doublequote '(#\"))\r
-\r
-(define (read-token port)\r
- (define ch (peek-char port))\r
- (define tok\r
- (cond [(eof-object? ch) ch]\r
- [(member ch whitespace) (consume-whitespace port)]\r
- [(char=? ch #\;) (consume-comment port)]\r
- [(char=? ch #\") (read-till-next #t port doublequote)]\r
- [(member ch punctuation) (string (read-char port))]\r
- [else (read-till-next #f port delimiters)]))\r
- (if (list? tok) (list->string tok) tok))\r
-\r
-(define (consume-whitespace port)\r
- (if (member (peek-char port) whitespace)\r
- (read-char port))\r
- (read-token port))\r
-\r
-(define (consume-comment port)\r
- (if (not (char=? #\newline (peek-char port)))\r
- (begin (read-char port)\r
- (consume-comment port))\r
- (begin (read-char port)\r
- (read-token port))))\r
-\r
-(define (read-till-next inc port delims)\r
- (cons (read-char port)\r
- (if (or (member (peek-char port) delims)\r
- (eof-object? (peek-char port)))\r
- (if inc (cons (read-char port) '()) '())\r
- (read-till-next inc port delims))))\r
-\r
-; Macro Expansion Phase\r
-;------------------------------------------------------------------------------\r
-; This phase is responsible for taking the expressions read from the input port\r
-; and performing macro expansion on them to get the resulting expression.\r
-\r
-(define (expand-macros expr)\r
- expr)\r
-\r
-; Desugaring Phase\r
-;------------------------------------------------------------------------------\r
-; The desugaring phase is responsible for taking user friendly extensions to\r
-; the core SCLPL syntax and deconstructing them into the low-level counterparts\r
-; defined by the "core" SCLPL syntax. This allows the code generator to work on\r
-; a small and well-defined subset of the SCLPL language.\r
-\r
-(define (desugar expr)\r
- (cond [(not (pair? expr)) expr]\r
- [(eqv? 'def (car expr)) (desugar-def expr)]\r
- [(eqv? 'if (car expr)) (desugar-if expr)]\r
- [(eqv? 'fn (car expr)) (append (list 'fn (cadr expr))\r
- (map desugar (cddr expr)))]\r
- [else (map desugar expr)]))\r
-\r
-(define (desugar-def expr)\r
- (cond [(annotated-def? expr) (desugar-annotated-def expr)]\r
- [(sugared-def? expr) (desugar-sugared-def expr)]\r
- [else (map desugar expr)]))\r
-\r
-(define (annotated-def? expr)\r
- (and (form-structure-valid? 'def >= 4 expr)\r
- (eqv? ': (caddr expr))))\r
-\r
-(define (sugared-def? expr)\r
- (and (form-structure-valid? 'def >= 2 expr)\r
- (arg-list-valid? (cadr expr))))\r
-\r
-(define (desugar-annotated-def expr)\r
- (let [(proto (cadr expr))\r
- (type (cadddr expr))\r
- (body (cddddr expr))]\r
- (if (pair? proto)\r
- (append `(def (,(car proto) ,type))\r
- (list (append `(fn ,(cdr proto)) (map desugar body))))\r
- (append `(def (,proto ,type))\r
- (map desugar body)))))\r
-\r
-(define (desugar-sugared-def expr)\r
- (if (pair? (cadr expr))\r
- (append `(def (,(caadr expr) ()))\r
- (list (append `(fn ,(cdadr expr)) (map desugar (cddr expr)))))\r
- (append `(def (,(cadr expr) ())) (map desugar (cddr expr)))))\r
-\r
-(define (desugar-if expr)\r
- (if (form-structure-valid? 'if = 3 expr)\r
- (map desugar (append expr '('())))\r
- (map desugar expr)))\r
-\r
-; Analysis Phase\r
-;------------------------------------------------------------------------------\r
-; The analysis phase is responsible for verifying that the provided expression\r
-; conforms to the requirements of the "core" SCLPL syntax. This phase will throw\r
-; an error for any invalid expression or simply return the provided expression\r
-; if it is valid.\r
-\r
-(define (analyze expr)\r
- (if (list? expr)\r
- (analyze-form expr)\r
- expr))\r
-\r
-(define (analyze-form expr)\r
- (if (null? expr)\r
- (error-msg 'non-atomic expr)\r
- (case (car expr)\r
- [(def) (analyze-def expr)]\r
- [(fn) (analyze-fn expr)]\r
- [(if) (validate-and-analyze 'if = 4 expr)]\r
- [(do) (validate-and-analyze 'do >= 1 expr)]\r
- [(quote) (validate-and-analyze 'quote = 2 expr)]\r
- [else (map analyze expr)])))\r
-\r
-(define (analyze-def expr)\r
- (validate-form 'def = 3 expr)\r
- (validate-signature (cadr expr))\r
- expr)\r
-\r
-(define (analyze-fn expr)\r
- (if (and (form-structure-valid? 'fn >= 3 expr)\r
- (arg-list-valid? (cadr expr)))\r
- (append (list 'fn (cadr expr))\r
- (map analyze (cddr expr)))\r
- (error-msg 'invalid-fn expr)))\r
-\r
-(define (validate-and-analyze type cmpop nargs expr)\r
- (validate-form type cmpop nargs expr)\r
- (map analyze expr))\r
-\r
-(define (validate-form type cmpop nargs expr)\r
- (cond [(not (pair? expr)) (error-msg 'not-an-sexp expr)]\r
- [(not (eqv? type (car expr))) (error-msg 'wrong-form-type expr)]\r
- [(not (cmpop (length expr) nargs)) (error-msg 'num-args expr)]))\r
-\r
-(define (validate-signature sig)\r
- (cond [(not (list? sig)) (error-msg 'sig-not-list sig)]\r
- [(not (= 2 (length sig))) (error-msg 'sig-num-entries sig)]\r
- [(not (variable? (car sig))) (error-msg 'sig-variable sig)]\r
- ;[(not (type? (cadr sig))) (error-msg 'expect-type sig)]))\r
- ))\r
-\r
-; Type Checking Phase\r
-;------------------------------------------------------------------------------\r
-; This phase is responsible for performing type reconstruction and verifying\r
-; that the expression is well-typed before being passed to the optimization and\r
-; compilation phases\r
-\r
-(define (check-type expr env)\r
- expr)\r
-\r
-; CPS-Conversion Phase\r
-;------------------------------------------------------------------------------\r
-; This phase translates the fully macro-expanded, desugared, and analyzed\r
-; program into continuation-passing style so various optimizations can be\r
-; performed before code is generated.\r
-\r
-(define (cps-convert expr)\r
- expr)\r
-\r
-; SCLPL to Scheme Phase\r
-;------------------------------------------------------------------------------\r
-\r
-(define (sclpl->scheme expr)\r
- expr)\r
-\r
-; Error Messages\r
-;------------------------------------------------------------------------------\r
-(define (error-msg type expr . args)\r
- (let [(handler (assoc type error-handlers))]\r
- (if handler (apply (cdr handler) args) (apply unknown-error args))\r
- (log-msg (with-output-to-string (lambda () (pretty-print expr))))\r
- (fail expr)))\r
-\r
-(define (non-atomic-expr)\r
- (log-msg "Error: Illegal non-atomic object"))\r
-\r
-(define (invalid-fn)\r
- (log-msg "Error: Invalid function form"))\r
-\r
-(define (not-an-sexpr)\r
- (log-msg "Error: Not an s-expression"))\r
-\r
-(define (wrong-form-type)\r
- (log-msg "Error: Incorrect form type"))\r
-\r
-(define (wrong-num-args)\r
- (log-msg "Error: Incorrect number of args for form"))\r
-\r
-(define (sig-is-not-a-list)\r
- (log-msg "Error: Function signature is not a list"))\r
-\r
-(define (wrong-num-sig-parts)\r
- (log-msg "Error: Function signature has incorrect number of parts"))\r
-\r
-(define (sig-name-not-var)\r
- (log-msg "Error: Name part of function signature is not a variable"))\r
-\r
-(define (expected-:)\r
- (log-msg "Error: Expected a :"))\r
-\r
-(define (unknown-error . args)\r
- (log-msg "Error: Unknown error occurred in the following expression"))\r
-\r
-(define error-handlers\r
- `((non-atomic . ,non-atomic-expr)\r
- (invalid-fn . ,invalid-fn)\r
- (not-an-sexp . ,not-an-sexpr)\r
- (wrong-form-type . ,wrong-form-type)\r
- (num-args . ,wrong-num-args)\r
- (sig-not-list . ,sig-is-not-a-list)\r
- (sig-num-entries . ,wrong-num-sig-parts)\r
- (sig-variable . ,sig-name-not-var)\r
- (expect-: . ,expected-:)))\r
-\r
-; Helper Predicates\r
-;------------------------------------------------------------------------------\r
-; This collection of predicate functions is used to assist the earlier phases\r
-; when dealing with similar data-structures.\r
-\r
-(define (form-structure-valid? type cmpop nargs expr)\r
- (and (pair? expr)\r
- (eqv? type (car expr))\r
- (cmpop (length expr) nargs)))\r
-\r
-(define (arg-list-valid? arglst)\r
- (or (variable? arglst)\r
- (and (or (list? arglst) (pair? arglst))\r
- (list-of? variable? arglst))))\r
-\r
-(define (list-of? type lst)\r
- (if (null? lst) #t\r
- (if (type (car lst))\r
- (if (type (cdr lst)) #t (list-of? type (cdr lst)))\r
- #f)))\r
-\r
-(define (variable? sym)\r
- (and (symbol? sym)\r
- (not (type-name? sym))\r
- (not (type-var? sym))))\r
-\r
-(define (atomic-base-type? type)\r
- (if (member type '(Any Number Symbol String Char Bool)) #t #f))\r
-\r
-(define (type? expr)\r
- (cond [(null? expr) #f]\r
- [(member '-> expr) (fn-type? expr)]\r
- [(list? expr) (and (> (length expr) 1)\r
- (apply list-and? (map type? expr)))]\r
- [else (or (type-name? expr) (type-var? expr))]))\r
-\r
-(define (type-name? sym)\r
- (and (symbol? sym)\r
- (let [(ch (string-ref (symbol->string sym) 0))]\r
- (and (char>=? ch #\A) (char<=? ch #\Z)))))\r
-\r
-(define (type-var? sym)\r
- (and (symbol? sym)\r
- (let [(ch (string-ref (symbol->string sym) 0))]\r
- (char=? ch #\?))))\r
-\r
-(define (fn-type? expr)\r
- (define (is-fn-type? prev expr)\r
- (if (null? expr) #t\r
- (case (car expr)\r
- [(...) (and (type? prev)\r
- (>= (length (cdr expr)) 1)\r
- (equal? '-> (cadr expr))\r
- (is-fn-type? #f (cdr expr)))]\r
- [(->) (and (= 2 (length expr))\r
- (is-fn-type? (car expr) (cdr expr)))]\r
- [else (and (type? (car expr))\r
- (is-fn-type? (car expr) (cdr expr)))])))\r
- (is-fn-type? #f expr))\r
-\r
-(define (list-and? . args)\r
- (if (null? args) #t (and (car args) (apply list-and? (cdr args)))))\r
-\r
-; Main\r
-;------------------------------------------------------------------------------\r
-\r
-(define fail error)\r
-\r
-(define log-msg (lambda args '()))\r
-\r
-;(define (print-data . args)\r
-; (apply print\r
-; (map (lambda (e)\r
-; (if (string? e)\r
-; e\r
-; (with-output-to-string (lambda () (pretty-print e)))))\r
-; args)))\r
-\r
-;(define (interpret port)\r
-; (call/cc (lambda (k)\r
-; (set! fail k)\r
-; (set! log-msg print)\r
-; (display (string-append ":" (sexp-count) "> "))\r
-; ; Read and type and analyze all expressions from input\r
-; (define expr (sclpl-read port))\r
-; (print-data "Read Phase: \n" expr)\r
-; (set! expr (expand-macros expr))\r
-; (print-data "Macro Expansion Phase: \n" expr)\r
-; (set! expr (desugar expr))\r
-; (print-data "Desugar Phase: \n" expr)\r
-; (set! expr (analyze expr))\r
-; (print-data "Analysis Phase: \n" expr)))\r
-; (interpret port))\r
-;(interpret (current-input-port))\r
-;(exit)\r
-\r
-(define (read-program port)\r
- (define expr (sclpl-read port))\r
- (if (eof-object? expr)\r
- '()\r
- (cons (analyze (desugar (expand-macros expr)))\r
- (read-program port))))\r
-\r
-(print (read-program (current-input-port)))\r
-\r
-\r
+++ /dev/null
-(declare (uses library server))\r
-\r
-(define slpkg-usage\r
-"Package manager for SCLPL (Simple Concurrent List Processing Language).\r
-\r
-Usage:\r
- slpkg [COMMAND] [OPTIONS]\r
-\r
-Commands:\r
- help Show help documentation for a specific command or subcommand.\r
- install Install one or more packages from the configured sources.\r
- publish Publish a package to a specified repository.\r
- remove Remove one or more packages from this machine.\r
- search Search the repositories for packages matching a pattern.\r
- server Start a package server to host packages.\r
- show Show detailed information about a specific package or packages.\r
- source Manage the sources from which packages will be retrieved.\r
- update Update the package lists for all configured sources.\r
- upgrade Upgrade a given package or packages.\r
-")\r
-\r
-;------------------------------------------------------------------------------\r
-\r
-(define (help-cmd args)\r
- (print args))\r
-\r
-;------------------------------------------------------------------------------\r
-(define install-cmd help-cmd)\r
-;------------------------------------------------------------------------------\r
-(define publish-cmd help-cmd)\r
-;------------------------------------------------------------------------------\r
-(define remove-cmd help-cmd)\r
-;------------------------------------------------------------------------------\r
-(define search-cmd help-cmd)\r
-;------------------------------------------------------------------------------\r
-\r
-(define (server-cmd args)\r
- (start-pkg-server (cadr args) (caddr args)))\r
-\r
-;------------------------------------------------------------------------------\r
-(define show-cmd help-cmd)\r
-;------------------------------------------------------------------------------\r
-(define source-cmd help-cmd)\r
-;------------------------------------------------------------------------------\r
-(define update-cmd help-cmd)\r
-;------------------------------------------------------------------------------\r
-(define upgrade-cmd help-cmd)\r
-;------------------------------------------------------------------------------\r
-\r
-(define slpkg-commands\r
- `(("help" . ,help-cmd)\r
- ("install" . ,install-cmd)\r
- ("publish" . ,publish-cmd)\r
- ("remove" . ,remove-cmd)\r
- ("search" . ,search-cmd)\r
- ("server" . ,server-cmd)\r
- ("show" . ,show-cmd)\r
- ("source" . ,source-cmd)\r
- ("update" . ,update-cmd)\r
- ("upgrade" . ,upgrade-cmd)))\r
-\r
-;------------------------------------------------------------------------------\r
-\r
-(define (cmd-dispatch cmd-map usage args)\r
- (define sub-cmd (if (pair? args) (assoc (car args) cmd-map) '()))\r
- (cond [(pair? sub-cmd) ((cdr sub-cmd) (cdr args))]\r
- [else (print usage)]))\r
-\r
-;------------------------------------------------------------------------------\r
-\r
-(cmd-dispatch slpkg-commands slpkg-usage (command-line-arguments))\r
-\r
+++ /dev/null
-(declare (unit server) (uses eval));(uses spiffy intarweb posix))\r
-(require-extension spiffy)\r
-\r
-(define index-template\r
-"<!DOCTYPE html PUBLIC\r
- \"-//W3C//DTD XHTML 1.0 Strict//EN\"\r
- \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\r
-<html lang=\"en\">\r
- <head>\r
- <title>Index of ~a</title>\r
- </head>\r
- <body>\r
- <div>~a</div>\r
- </body>\r
-</html>")\r
-\r
-(define entry-template "<a href=\"~a\">~a</a><br/>\n")\r
-\r
-(define (html-response html)\r
- (with-headers `((content-type text/html)\r
- (content-length ,(string-length html)))\r
- (lambda ()\r
- (write-logged-response)\r
- (display html (response-port (current-response))))))\r
-\r
-(define (generate-index path)\r
- (define curr_root (string-append (root-path) path))\r
- (define entries (glob (string-append curr_root "/*")))\r
- (apply string-append\r
- (map (lambda (e)\r
- (define pth (if (equal? "/" path) path (string-append path "/" e)))\r
- (sprintf entry-template pth e))\r
- (map (lambda (e) (car (reverse (string-split e "/"))))\r
- entries))))\r
-\r
-(define (index-handler path)\r
- (html-response (sprintf index-template path (generate-index path))))\r
-\r
-(define (start-pkg-server port root)\r
- (server-port port)\r
- (root-path root)\r
- (handle-directory index-handler)\r
- (start-server))\r
-\r
projects / proto / sclpl.git / commitdiff