From 355392d0c070799522332afe4a75f56e067af2b6 Mon Sep 17 00:00:00 2001 From: "Michael D. Lowis" Date: Sun, 26 Oct 2014 20:39:53 -0400 Subject: [PATCH] Removed all unused source files --- source/libsof/libsof.c | 269 ---------------------- source/libsof/libsof.h | 42 ---- source/libsof/libsof.os | Bin 8768 -> 0 bytes source/libsof/sof.h | 68 ------ source/readsof/main.c | 94 -------- source/runtime/collector/gc.c | 208 ----------------- source/runtime/collector/gc.h | 32 --- source/runtime/sclpl.h | 0 source/runtime/types/types.c | 43 ---- source/runtime/types/types.h | 49 ---- source/slas/main.scm | 22 -- source/slbuild/main.scm | 241 -------------------- source/slc/main.scm | 412 ---------------------------------- source/slpkg/main.scm | 72 ------ source/slpkg/server.scm | 44 ---- 15 files changed, 1596 deletions(-) delete mode 100644 source/libsof/libsof.c delete mode 100644 source/libsof/libsof.h delete mode 100644 source/libsof/libsof.os delete mode 100644 source/libsof/sof.h delete mode 100644 source/readsof/main.c delete mode 100644 source/runtime/collector/gc.c delete mode 100644 source/runtime/collector/gc.h create mode 100644 source/runtime/sclpl.h delete mode 100644 source/runtime/types/types.c delete mode 100644 source/runtime/types/types.h delete mode 100644 source/slas/main.scm delete mode 100644 source/slbuild/main.scm delete mode 100644 source/slc/main.scm delete mode 100644 source/slpkg/main.scm delete mode 100644 source/slpkg/server.scm diff --git a/source/libsof/libsof.c b/source/libsof/libsof.c deleted file mode 100644 index d6d3ab0..0000000 --- a/source/libsof/libsof.c +++ /dev/null @@ -1,269 +0,0 @@ -/** - @file libsof.c - @brief See header for details - $Revision$ - $HeadURL$ - */ -#include "libsof.h" -#include -#include -#include -#include - -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; -} - diff --git a/source/libsof/libsof.h b/source/libsof/libsof.h deleted file mode 100644 index 4e9489f..0000000 --- a/source/libsof/libsof.h +++ /dev/null @@ -1,42 +0,0 @@ -/** - @file libsof.h - @brief TODO: Describe this file - $Revision$ - $HeadURL$ - */ -#ifndef LIBSOF_H -#define LIBSOF_H - -#include "sof.h" -#include -#include -#include - -typedef struct { - sof_header_t* header; - sof_st_entry_t* symbols; - char* strings; - uint8_t* data; - uint32_t* code; -} sof_file_t; - -sof_file_t* libsof_read_obj(char const* fname); -bool libsof_write_obj(sof_file_t* obj, char const* fname); -sof_file_t* libsof_new_obj(void); -void libsof_free_obj(sof_file_t* obj); -size_t libsof_get_symbol_table_size(sof_file_t* obj); -size_t libsof_get_string_table_size(sof_file_t* obj); -size_t libsof_get_data_segment_size(sof_file_t* obj); -size_t libsof_get_code_segment_size(sof_file_t* obj); -size_t libsof_get_num_symbols(sof_file_t* obj); -size_t libsof_add_symbol(sof_file_t* obj, const char* name, uint32_t value, uint32_t size, uint32_t 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 const* libsof_get_st_entry(sof_file_t* obj, size_t offset); -size_t libsof_add_string(sof_file_t* obj, char const* name); -char const* libsof_get_string(sof_file_t* obj, size_t offset); -size_t libsof_add_data(sof_file_t* obj, uint8_t const* data, size_t length); -uint8_t const* libsof_get_data(sof_file_t* obj, size_t offset); -size_t libsof_add_code(sof_file_t* obj, uint32_t const* code, size_t length); -uint32_t const* libsof_get_code(sof_file_t* obj, size_t offset); - -#endif /* LIBSOF_H */ diff --git a/source/libsof/libsof.os b/source/libsof/libsof.os deleted file mode 100644 index b7fc8bdbd1262c37985c4f088d7f4a60470dbb75..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 8768 zcmX^A>+L^w1_nlE1_lO31_lNY{Q<;KU;qP21_p)>5FgCLBqD?%VggJM8pda5U|;}Y z7KkuIe0)i2MG2I{z`zh6AL1Gjg5bkgC%7Oika-}z8KMjfrXV2}h6WG?!}0OS#U(|V zdFfCAbn{^5utDW-@IV<*3hG=a59FTY{M>@XqGDVDMyMV3;7oz_5W8td1c7B+kIVAPvPT3=9nR3=9lVCqre4qe4A8 zpL#UEQSj&mhq^~+?GKORt{*^}J-TauyZ|#gU0--K)`HpmEpZGC3?BPoNyKBH21p45 z0|Qvvqto?+M|bTDkM7bB5CJkdFwGx2U7vV#{_to%q7ZwSU!DQ(-W?)Pd%;fbEdAio zc^sl?A6#Y^+?Cz6A3QqQJ-R`zWANzq{Q*}E@*CLjG=6y(288*bfB>1=UHZYJ+pMt; z9B=$B?jYYojOq4Z={yg$64fGi4v0+-93CKxyY0LESvpVQur>_@^!Vjl!2W^z58Zwa zkTib_D3L-8XXy6ez-7MxL`emd1}g>I4{4q({zD000bKSeK$jHC#VyEk!&I=yRM+{;Qr(wiDB7GxL zF>0ECq^Iv52q(XQWRtWs4F4*?JPOK~$m!V@u)w6nJ#jzVPTg?g0+y7hs=wbh;lS=gp(-|{(+`f ztmYF;mPD8j4kG>*NO*w@1CUQ3;icfw4Gk{=aCkA199{yrOH`zy7GAJ*y28?7=?{-i zHji%CA0FKd#~HXd?}7?BP;n^$DlQ#h<(U9D{<~{`cy!xCq7KZi=RoENAaf*;ISOzN zgwcEiY&@*I1jRMjJo|2Ume|7>=?__+gMd5_0eJxe@+_UlJr2HS@#y>k3ILe@4Z!~I zEd9_K`li$Og$t-w0lOGhO?A5707qK4>y6HX-Jx$>x?Nwmbo)N(Jm=DR(6#df%-^8A zis8TJH*oVoMTAG=F;HrOm}l?NcpQ}WJ-S0bfJ-e{HY$DK(HVLJVlFEvLwG<6l@}h} zp*K7_4?<)hr2|I#H1OB~vI0~*`SkkU0Qs)7^h;;xhfd!&E}gC~x_!TN`rhdF{m|)q zr`z{Ur|*Mq-xr;}Prz=1ILN0v^oMV^kZ0o|P-^z+yynw+3e{SEd3gFk_^&hcg-56F z189o(==8ne(d~P~gBc_g`oW`<3tTL9TS62VLVU6FKNNU$hyL*BWP&DG4`xuPmx6r! z0A6x~OzU*L;L&*kS~P+RaP;z9!DAQ9{~*76Kx*nA9^GZ2Di@T>yWK%40hBMn0sh^i zyA)bzfopq|@(PqbK_7269xu` zA5eAp?B!u(UJJfS1_leLI%v6r zRh> z(DDnbc}rLr7(AfraQSy17Xt$?1A}e`7Xt$i1B0$Glz)*E!f)n;$iL%&(7hbsF+ANw z4h9By1_oUr4v4zh>=3$CgJiy0y69ijX`3=sY~28jGj28eqmFfcH%GBD^i zGcYi)FfizrLB_OoGZ`2_O)*_iIl{=mpbJVLAb*1ztsr-CgA+Z2>;h)+I5=Aalum%s z4p3SFN`nT<85tPZ9xy@FAAr&epmYP22Kfu5&H>6-fYKnxfW#j#LiI!G1yH&HN+&>R z2Pmxor9p%BVEvFvo9zIUUI3**oez+F0+jCnr9u7$iG#cgqCx)TV`5-{jhDAGGcfQm zGBCi}#j~M&SUY$Fln<(dL1r9<@?C?D4DjDYfC?WBAtACw3|?&$#WSr`~#H%Hu}=mn4{Ntxfy$qN%5y^HVeQ_1Q27N=c~GAVuyy|H0bjO;G&-Q1j=&?1#2HU7-3OK>fEBsvp+wPlW2%fa?DU zm4~(K7enPMpz_I3^I`33CaC!iQ1dIG^00QZ6jXi!RDL?td|1B(lo-1z%FlqN z$52T50n^R^n%@JN2@_C+loK#61ISy*@`h;g#b|slG`=Pp-v`Zp7c@RYd`@Okaei8S zQEFmJe11|ELws6(L24dDd~#w=PJS{&d|Gl&esL;8d@hU+QVG{qUX)pq3e^W@!)5YP z%OT=W3(|^GVG4^nm;ku|1F|^Si_qx76bHo+vM9(#kav*9KqjDzfz*L~g{}@J<`b`1Tv7y&BXGQBq$Z}M zqKQF#he)Pig^(F}G(nIHP|X9`#Q?F$5H15r4QN(D1kvq+ih@HDVHrde#Wsi#*gE9I zT#^rqQ@HJ*pn_%E#FUgG23HTr?7ab83D}1a_aO%!SQzR;OmT=CF~mWx#1I6z6Il@A ldQ2N3;#jPNN?_UvkwCW;B8qM+D1jgX2-!X8VFZ$6000PMB6|P; diff --git a/source/libsof/sof.h b/source/libsof/sof.h deleted file mode 100644 index cf82684..0000000 --- a/source/libsof/sof.h +++ /dev/null @@ -1,68 +0,0 @@ -/** - @file sof.h - @brief TODO: Describe this file - $Revision$ - $HeadURL$ - */ -#ifndef SOF_H -#define SOF_H - -#include - -/* - SCLPL Object File Layout - - ----------------------- - | SOF Header | - ----------------------- - | Symbol Table | - ----------------------- - | Symbol String Table | - ----------------------- - | Data Segment | - ----------------------- - | Code Segment | - ----------------------- - -*/ - -/* Macro for generating a 32-bit date code based on year, month, and day */ -#define DATE_CODE(year,month,day) (year << 16) | (month << 8) | (day) - -/* The version of the SOF format supported by this library represented as a - * 32-bit date code */ -#define SOF_VERSION DATE_CODE(2013,9,10) - -/* Definition of the SOF file header. The header appears at the beginning of any - * SOF file and contains information about the SOF version of the file and the - * sizes of each section in the file. */ -typedef struct { - /* 32-bit date code representing the version of SOF format used by the file */ - uint32_t version; - /* This size of the symbol table in bytes. A value of 0 indicates that the - * symbol table segment has been omitted from the file */ - uint32_t sym_tbl_sz; - /* The size of the symbol string table segment in bytes. Each entry in the - * symbol string table consists of an array of bytes terminated by a NULL - * byte (0x00). */ - uint32_t sym_str_tbl_sz; - /* The size in bytes of the constant data segment. This segment contains - * constant data that is referenced by the code segment. */ - uint32_t data_sz; - /* The size of the code segment in bytes. Each instruction is represented by - * a 32-bit value and represents a single action to be performed by the - * bytecode interpreter. */ - uint32_t code_sz; -} sof_header_t; - -/* Definition of the SOF symbol table entry */ -typedef struct { - /* Offset into the string section where the string for the symbol is - * located */ - uint32_t name; - uint32_t value; - uint32_t size; - uint32_t info; -} sof_st_entry_t; - -#endif /* SOF_H */ diff --git a/source/readsof/main.c b/source/readsof/main.c deleted file mode 100644 index d7a9d17..0000000 --- a/source/readsof/main.c +++ /dev/null @@ -1,94 +0,0 @@ -#include -#include - -#define GET_VERSION_YEAR(version) (version >> 16) -#define GET_VERSION_MONTH(version) ((version >> 8) & 0xFF) -#define GET_VERSION_DAY(version) (version & 0xFF) - -void print_obj(sof_file_t* obj); -void print_hex(char const* header, uint8_t const* buffer, size_t length); - -void create_obj_file(char* fname) -{ - sof_file_t* obj = libsof_new_obj(); - - libsof_add_symbol(obj, "foo", 0x11223344, 0x22222222, 0x33333333); - - uint8_t data[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 }; - libsof_add_data(obj, data, 16); - libsof_add_data(obj, data, 16); - libsof_add_data(obj, data, 16); - - uint32_t code[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 }; - libsof_add_code(obj, code, 16); - libsof_add_code(obj, code, 16); - libsof_add_code(obj, code, 16); - - libsof_write_obj(obj,fname); - libsof_free_obj(obj); -} - -void print_obj(sof_file_t* obj) -{ - /* print header metadata */ - printf("SOF Version:\t%#x (%d/%d/%d)\n", - obj->header->version, - GET_VERSION_DAY(obj->header->version), - GET_VERSION_MONTH(obj->header->version), - GET_VERSION_YEAR(obj->header->version)); - printf("Symbol Table:\t%d bytes\n", obj->header->sym_tbl_sz); - printf("String Table:\t%d bytes\n", obj->header->sym_str_tbl_sz); - printf("Data Size:\t%d bytes\n", obj->header->data_sz); - printf("Code Size:\t%d bytes\n", obj->header->code_sz); - - /* print symbol table */ - printf("\nIndex\tValue\t\tSize\t\tInfo\t\tName\n"); - for(size_t i = 0; i < libsof_get_num_symbols(obj); i++) - { - sof_st_entry_t const* symbol = libsof_get_st_entry(obj,i); - char const* name = libsof_get_string(obj,symbol->name); - printf("[%d]\t%#x\t%#x\t%#x\t%s\n", i, symbol->value, symbol->size, symbol->info, name); - } - - /* print segments as hex listing */ - print_hex("Data Segment", (uint8_t const *)libsof_get_data(obj,0), libsof_get_data_segment_size(obj)); - print_hex("Code Segment", (uint8_t const *)libsof_get_code(obj,0), libsof_get_code_segment_size(obj)); -} - -void print_hex(char const* header, uint8_t const* buffer, size_t length) -{ - printf("\n\n%s\n",header); - printf("----------------------------------------------------------"); - for(size_t i = 0; i < length; i++) - { - if ((i%16) == 0) - { - printf("\n0x%04x\t", i); - } - else if ((i%4) == 0) - { - printf(" "); - } - printf("%02x ", buffer[i]); - } -} - -int main(int argc, char** argv) -{ - if (argc == 1) - { - printf("%s: no input files.\n", argv[0]); - } - else - { - create_obj_file(argv[1]); - for (uint32_t i = 1; i < argc; i++) - { - printf("\nFilename:\t%s\n", argv[i]); - sof_file_t* obj = libsof_read_obj(argv[i]); - print_obj(obj); - libsof_free_obj(obj); - } - } -} - diff --git a/source/runtime/collector/gc.c b/source/runtime/collector/gc.c deleted file mode 100644 index c4ad125..0000000 --- a/source/runtime/collector/gc.c +++ /dev/null @@ -1,208 +0,0 @@ -#include -#include -#include -#include -#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 -#include - -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 - diff --git a/source/runtime/collector/gc.h b/source/runtime/collector/gc.h deleted file mode 100644 index 5d62fd4..0000000 --- a/source/runtime/collector/gc.h +++ /dev/null @@ -1,32 +0,0 @@ -/** - @file gc.h - @brief Public interface for the garbage collector. - $Revision$ - $HeadURL$ -*/ -#ifndef GC_H -#define GC_H - -#include - -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 */ diff --git a/source/runtime/sclpl.h b/source/runtime/sclpl.h new file mode 100644 index 0000000..e69de29 diff --git a/source/runtime/types/types.c b/source/runtime/types/types.c deleted file mode 100644 index f0e77fe..0000000 --- a/source/runtime/types/types.c +++ /dev/null @@ -1,43 +0,0 @@ -/** - @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; -} - diff --git a/source/runtime/types/types.h b/source/runtime/types/types.h deleted file mode 100644 index ba2b703..0000000 --- a/source/runtime/types/types.h +++ /dev/null @@ -1,49 +0,0 @@ -/** - @file types.h - @brief TODO: Describe this file - $Revision$ - $HeadURL$ -*/ -#ifndef TYPES_H -#define TYPES_H - -#include -#include - -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 */ diff --git a/source/slas/main.scm b/source/slas/main.scm deleted file mode 100644 index 5c98197..0000000 --- a/source/slas/main.scm +++ /dev/null @@ -1,22 +0,0 @@ -(declare (uses library)) - -(define usage -"\nUsage: slas - -Assemble to SCLPL bytecode and write the result to .\n") - -; Control Routines -;------------------------------------------------------------------------------ -(define (assemble-file infile outfile) - (define iprt (open-input-file infile)) - (define oprt (open-output-file outfile)) - (generate-bytecode iprt oprt)) - -(define (generate-bytecode iprt oprt) '()) - -; Main routine -;------------------------------------------------------------------------------ -(if (= 2 (length (command-line-arguments))) - (apply assemble-file (command-line-arguments)) - (print usage)) -(exit) diff --git a/source/slbuild/main.scm b/source/slbuild/main.scm deleted file mode 100644 index 00766c8..0000000 --- a/source/slbuild/main.scm +++ /dev/null @@ -1,241 +0,0 @@ -(declare (uses posix)) -(use posix) - -; Task Definition and Interaction -;------------------------------------------------------------------------------ -(define-record task name desc active? deps actions) - -(define top-level-tasks '()) - -(define current-namespace - (make-parameter '())) - -(define current-desc - (make-parameter #f)) - -(define (task-register! task) - (define name (task-name task)) - (define entry (assoc name top-level-tasks)) - (if (not entry) - (set! top-level-tasks (cons (cons name task) top-level-tasks)) - (set-cdr! entry (task-merge (cdr entry) task)))) - -(define (task-merge task1 task2) - (make-task (task-name task1) (task-desc task1) #t - (append (task-deps task1) - (task-deps task2)) - (append (task-actions task1) - (task-actions task2)))) - -(define (task-lookup name) - (define entry (assoc name top-level-tasks)) - (if (not entry) - (error (string-append "No such task: " name)) - (cdr entry))) - -(define (task-invoke! name) - (define task (task-lookup name)) - (if (task-active? task) - (begin (task-active?-set! task #f) - (map task-invoke! (task-deps task)) - (map (lambda (fn) (fn)) (task-actions task))))) - -(define (gen-task-name name) - (define namespace (current-namespace)) - (if (not (null? namespace)) - (string-append namespace ":" name) - name)) - -; Environment Functions -;------------------------------------------------------------------------------ -(define-record builder defaults action) - -(define (get-sys-env) - (get-environment-variables)) - -(define (set-sys-env! newenv) - (clear-sys-env!) - (map (lambda (p) (setenv (car p) (cdr p))) - newenv)) - -(define (clear-sys-env!) - (map (lambda (p) (unsetenv (car p))) - (get-environment-variables))) - -(define current-env - (let [(curr-env (get-sys-env))] - (lambda args - (if (> (length args) 0) - (begin (set-sys-env! (car args)) - (set! curr-env (car args))) - curr-env)))) - -(define (env-clone env . vars) - (define newenv (map (lambda (p) (cons (car p) (cdr p))) env)) - (define newvals '()) - (map (lambda (e) - (define entry (assoc (car e) newenv)) - (if entry - (set-cdr! entry (cdr e)) - (set! newvals (cons e newvals)))) - vars) - (append newvals newenv)) - -(define (env-get env key) - (define entry (assoc key env)) - (if entry (cdr entry) #f)) - -(define (env-set env key value) - (cons (cons key value) - (env-unset env key))) - -(define (env-unset env key) - (cond [(null? env) '()] - [(string=? (caar env) key) (env-unset (cdr env) key)] - [else (cons (car env) (env-unset (cdr env) key))])) - -(define (env-extend env . vars) - (foldl (lambda (env p) - (env-set env (car p) (cdr p))) - env - vars)) - -(define (env-substitute env str) - (list->string (sub-vars (string->list str) env))) - -(define (env-prepend-path env path) - '()) - -(define (env-append-path env path) - '()) - -(define (env-add-builders env . builders) - '()) - -; Builders -;------------------------------------------------------------------------------ - - -; System Utility Functions -;------------------------------------------------------------------------------ -(define verbose #f) - -(define (build type . args) - (define bldr (assoc type (assoc "builders" (current-env)))) - (define bldr-env (env-merge (builder-defaults bldr) (current-env))) - (apply (builder-action bldr) (cons bldr-env args))) - -(define (run . args) - (define cmd (env-substitute (current-env) (string-join args " "))) - (if verbose (print cmd)) - (if (not (= 0 (system cmd))) - (fail-build cmd))) - -(define (fail-build cmd) - (print "Error: Command returned a non-zero status") - (exit 1)) - -; Directories -(define cd change-directory) -(define curdir current-directory) -(define mkdir create-directory) -(define rmdir delete-directory) -(define lsdir directory) -(define dir? directory?) -; glob - -; Files -(define cp '()) -(define mv '()) -(define rm delete-file) - -; String Templating -;------------------------------------------------------------------------------ -(define (sub-vars chlst env) - (cond [(null? chlst) '()] - [(char=? #\$ (car chlst)) (let [(pair (replace-var (cdr chlst) env))] - (append (string->list (car pair)) - (sub-vars (cdr pair) env)))] - [else (cons (car chlst) (sub-vars (cdr chlst) env))])) - -(define (replace-var chlst env) - (define tok '()) - (define (collect-var-chars chlst) - (if (or (null? chlst) (char=? (car chlst) #\space)) - (set! tok (cons (list->string (reverse tok)) chlst)) - (begin (set! tok (cons (car chlst) tok)) - (collect-var-chars (cdr chlst))))) - (collect-var-chars chlst) - (let [(var (env-get env (car tok)))] - (if var - (cons var (cdr tok)) - (cons "" (cdr tok))))) - -;(define (scan-tok chlst tok) -; (cond [(or (null? chlst) (char=? #\space (car chlst))) -; (list->string (reverse tok))] - -; System Utility Functions -;------------------------------------------------------------------------------ -(define (string-join strlst jstr) - (foldl (lambda (a b) (string-append a b jstr)) "" strlst)) - -; DSL Definition -;------------------------------------------------------------------------------ -(define-syntax task - (syntax-rules (=>) - [(_ name => (deps ...)) - (task-register! (make-task (gen-task-name name) (current-desc) #t '(deps ...) '()))] - [(_ name => (deps ...) exp1 expn ...) - (task-register! - (make-task (gen-task-name name) (current-desc) #t '(deps ...) - (list (lambda () exp1 expn ...))))] - [(_ name exp1 expn ...) - (task-register! - (make-task (gen-task-name name) (current-desc) #t '() - (list (lambda () exp1 expn ...))))])) - -(define-syntax namespace - (syntax-rules () - [(_ name body ...) - (let [(prev-ns (current-namespace))] - (current-namespace (gen-task-name name)) - body ... - (current-namespace prev-ns))])) - -(define (desc str) - (current-desc str)) - -(define-syntax environment - (syntax-rules (<=) - [(_ name <= parent vars ...) - (define name (env-extend parent vars ...))] - [(_ name vars ...) - (define name (env-extend (current-env) vars ...))])) - -(define-syntax builder - (syntax-rules (defaults action) - [(_ (defaults vars ...) (action args body ...)) - (make-builder '(vars ...) (lambda args body ...))])) - -; Core Tasks -;------------------------------------------------------------------------------ -(task "verbose" - (set! verbose #t)) - -(task "help" - (map (lambda (t) - (if (task-desc (cdr t)) - (print (string-append (task-name (cdr t)) " - " (task-desc (cdr t)))))) - top-level-tasks)) -; Main -;------------------------------------------------------------------------------ -(define (run-top-level-tasks!) - (map task-invoke! - (if (= 0 (length (command-line-arguments))) - '("default") - (command-line-arguments)))) - -(load "Spadefile") -(run-top-level-tasks!) - diff --git a/source/slc/main.scm b/source/slc/main.scm deleted file mode 100644 index 5079ac5..0000000 --- a/source/slc/main.scm +++ /dev/null @@ -1,412 +0,0 @@ -; Regex Matching Macro -;------------------------------------------------------------------------------ -(use regex ports extras) - -(define-syntax regex-case - (syntax-rules (else) - ((_ item (else result1 result2 ...)) - (begin result1 result2 ...)) - - ((_ item (regex result1 result2 ...)) - (if (string-match regex item) (begin result1 result2 ...))) - - ((_ item (regex result1 result2 ...) clause1 clause2 ...) - (if (string-match regex item) - (begin result1 result2 ...) - (regex-case item clause1 clause2 ...))))) - -; Reader Phase -;------------------------------------------------------------------------------ -; This phase is responsible reading input from a port and constructing the -; expression that the input represents. - -(define (sclpl-read port) - (let [(tok (read-token port))] - (if (eof-object? tok) - tok - (cond [(list-op? tok) (read-sexp port (get-sexp-term tok))] - [(equal? "'" tok) `(quote ,(sclpl-read port))] - [(equal? "`" tok) `(quasiquote ,(sclpl-read port))] - [else (classify-atom tok)])))) - -(define (read-sexp port term) - (define expr (sclpl-read port)) - (cond [(equal? expr term) '()] - [(wrong-term? expr term) (error "Incorrectly matched list terminator")] - [(equal? '|.| expr) (read-and-term port term)] - [else (cons expr (read-sexp port term))])) - - -(define (read-and-term port term) - (define val (sclpl-read port)) - (define tval (sclpl-read port)) - (cond [(member val '(#\) #\] #\})) (error "")] - [(equal? tval term) val] - [(wrong-term? tval term) (error "")] - [else (error "")])) - -(define (classify-atom atom) - (regex-case atom - ["nil" '()] - ["true" #t] - ["false" #f] - ["^\".*\"$" (dequote atom)] - ["^\\\\.+" (atom->char atom)] - ["[{[()\\]}]" (string-ref atom 0)] - ["#[dbox](#[ie])?.+" (or (string->number atom) (string->symbol atom))] - ["[+-]?[0-9].*" (or (string->number atom) (string->symbol atom))] - [else (if (string-literal? atom) - (dequote atom) - (string->symbol atom))])) - -(define (list-op? tok) - (member (string-ref tok 0) '(#\( #\[ #\{))) - -(define (get-sexp-term tok) - (define pairs '((#\( . #\)) (#\[ . #\]) (#\{ . #\}))) - (define term (assv (string-ref tok 0) pairs)) - (if term (cdr term) (error "Not a valid s-expression delimiter"))) - -(define (wrong-term? expr term) - (define terms '(#\) #\] #\})) - (and (not (equal? expr term)) - (member expr terms))) - -(define (string-literal? atom) - (and (char=? #\" (string-ref atom 0)) - (char=? #\" (string-ref atom (- (string-length atom) 1))))) - -(define (dequote str) - (substring str 1 (- (string-length str) 1))) - -(define (atom->char atom) - (define ch-name (substring atom 1)) - (define ch (if (= 1 (string-length ch-name)) - (string-ref ch-name 0) - (char-name (string->symbol ch-name)))) - (or ch (error (string-append "Invalid character name: " ch-name)))) - -;------------------------------------------------------------------------------ - -(define whitespace (string->list " \t\r\n")) -(define punctuation (string->list "()[]{}'`:,")) -(define delimiters (string->list "()[]{}'`:,; \t\r\n")) -(define doublequote '(#\")) - -(define (read-token port) - (define ch (peek-char port)) - (define tok - (cond [(eof-object? ch) ch] - [(member ch whitespace) (consume-whitespace port)] - [(char=? ch #\;) (consume-comment port)] - [(char=? ch #\") (read-till-next #t port doublequote)] - [(member ch punctuation) (string (read-char port))] - [else (read-till-next #f port delimiters)])) - (if (list? tok) (list->string tok) tok)) - -(define (consume-whitespace port) - (if (member (peek-char port) whitespace) - (read-char port)) - (read-token port)) - -(define (consume-comment port) - (if (not (char=? #\newline (peek-char port))) - (begin (read-char port) - (consume-comment port)) - (begin (read-char port) - (read-token port)))) - -(define (read-till-next inc port delims) - (cons (read-char port) - (if (or (member (peek-char port) delims) - (eof-object? (peek-char port))) - (if inc (cons (read-char port) '()) '()) - (read-till-next inc port delims)))) - -; Macro Expansion Phase -;------------------------------------------------------------------------------ -; This phase is responsible for taking the expressions read from the input port -; and performing macro expansion on them to get the resulting expression. - -(define (expand-macros expr) - expr) - -; Desugaring Phase -;------------------------------------------------------------------------------ -; The desugaring phase is responsible for taking user friendly extensions to -; the core SCLPL syntax and deconstructing them into the low-level counterparts -; defined by the "core" SCLPL syntax. This allows the code generator to work on -; a small and well-defined subset of the SCLPL language. - -(define (desugar expr) - (cond [(not (pair? expr)) expr] - [(eqv? 'def (car expr)) (desugar-def expr)] - [(eqv? 'if (car expr)) (desugar-if expr)] - [(eqv? 'fn (car expr)) (append (list 'fn (cadr expr)) - (map desugar (cddr expr)))] - [else (map desugar expr)])) - -(define (desugar-def expr) - (cond [(annotated-def? expr) (desugar-annotated-def expr)] - [(sugared-def? expr) (desugar-sugared-def expr)] - [else (map desugar expr)])) - -(define (annotated-def? expr) - (and (form-structure-valid? 'def >= 4 expr) - (eqv? ': (caddr expr)))) - -(define (sugared-def? expr) - (and (form-structure-valid? 'def >= 2 expr) - (arg-list-valid? (cadr expr)))) - -(define (desugar-annotated-def expr) - (let [(proto (cadr expr)) - (type (cadddr expr)) - (body (cddddr expr))] - (if (pair? proto) - (append `(def (,(car proto) ,type)) - (list (append `(fn ,(cdr proto)) (map desugar body)))) - (append `(def (,proto ,type)) - (map desugar body))))) - -(define (desugar-sugared-def expr) - (if (pair? (cadr expr)) - (append `(def (,(caadr expr) ())) - (list (append `(fn ,(cdadr expr)) (map desugar (cddr expr))))) - (append `(def (,(cadr expr) ())) (map desugar (cddr expr))))) - -(define (desugar-if expr) - (if (form-structure-valid? 'if = 3 expr) - (map desugar (append expr '('()))) - (map desugar expr))) - -; Analysis Phase -;------------------------------------------------------------------------------ -; The analysis phase is responsible for verifying that the provided expression -; conforms to the requirements of the "core" SCLPL syntax. This phase will throw -; an error for any invalid expression or simply return the provided expression -; if it is valid. - -(define (analyze expr) - (if (list? expr) - (analyze-form expr) - expr)) - -(define (analyze-form expr) - (if (null? expr) - (error-msg 'non-atomic expr) - (case (car expr) - [(def) (analyze-def expr)] - [(fn) (analyze-fn expr)] - [(if) (validate-and-analyze 'if = 4 expr)] - [(do) (validate-and-analyze 'do >= 1 expr)] - [(quote) (validate-and-analyze 'quote = 2 expr)] - [else (map analyze expr)]))) - -(define (analyze-def expr) - (validate-form 'def = 3 expr) - (validate-signature (cadr expr)) - expr) - -(define (analyze-fn expr) - (if (and (form-structure-valid? 'fn >= 3 expr) - (arg-list-valid? (cadr expr))) - (append (list 'fn (cadr expr)) - (map analyze (cddr expr))) - (error-msg 'invalid-fn expr))) - -(define (validate-and-analyze type cmpop nargs expr) - (validate-form type cmpop nargs expr) - (map analyze expr)) - -(define (validate-form type cmpop nargs expr) - (cond [(not (pair? expr)) (error-msg 'not-an-sexp expr)] - [(not (eqv? type (car expr))) (error-msg 'wrong-form-type expr)] - [(not (cmpop (length expr) nargs)) (error-msg 'num-args expr)])) - -(define (validate-signature sig) - (cond [(not (list? sig)) (error-msg 'sig-not-list sig)] - [(not (= 2 (length sig))) (error-msg 'sig-num-entries sig)] - [(not (variable? (car sig))) (error-msg 'sig-variable sig)] - ;[(not (type? (cadr sig))) (error-msg 'expect-type sig)])) - )) - -; Type Checking Phase -;------------------------------------------------------------------------------ -; This phase is responsible for performing type reconstruction and verifying -; that the expression is well-typed before being passed to the optimization and -; compilation phases - -(define (check-type expr env) - expr) - -; CPS-Conversion Phase -;------------------------------------------------------------------------------ -; This phase translates the fully macro-expanded, desugared, and analyzed -; program into continuation-passing style so various optimizations can be -; performed before code is generated. - -(define (cps-convert expr) - expr) - -; SCLPL to Scheme Phase -;------------------------------------------------------------------------------ - -(define (sclpl->scheme expr) - expr) - -; Error Messages -;------------------------------------------------------------------------------ -(define (error-msg type expr . args) - (let [(handler (assoc type error-handlers))] - (if handler (apply (cdr handler) args) (apply unknown-error args)) - (log-msg (with-output-to-string (lambda () (pretty-print expr)))) - (fail expr))) - -(define (non-atomic-expr) - (log-msg "Error: Illegal non-atomic object")) - -(define (invalid-fn) - (log-msg "Error: Invalid function form")) - -(define (not-an-sexpr) - (log-msg "Error: Not an s-expression")) - -(define (wrong-form-type) - (log-msg "Error: Incorrect form type")) - -(define (wrong-num-args) - (log-msg "Error: Incorrect number of args for form")) - -(define (sig-is-not-a-list) - (log-msg "Error: Function signature is not a list")) - -(define (wrong-num-sig-parts) - (log-msg "Error: Function signature has incorrect number of parts")) - -(define (sig-name-not-var) - (log-msg "Error: Name part of function signature is not a variable")) - -(define (expected-:) - (log-msg "Error: Expected a :")) - -(define (unknown-error . args) - (log-msg "Error: Unknown error occurred in the following expression")) - -(define error-handlers - `((non-atomic . ,non-atomic-expr) - (invalid-fn . ,invalid-fn) - (not-an-sexp . ,not-an-sexpr) - (wrong-form-type . ,wrong-form-type) - (num-args . ,wrong-num-args) - (sig-not-list . ,sig-is-not-a-list) - (sig-num-entries . ,wrong-num-sig-parts) - (sig-variable . ,sig-name-not-var) - (expect-: . ,expected-:))) - -; Helper Predicates -;------------------------------------------------------------------------------ -; This collection of predicate functions is used to assist the earlier phases -; when dealing with similar data-structures. - -(define (form-structure-valid? type cmpop nargs expr) - (and (pair? expr) - (eqv? type (car expr)) - (cmpop (length expr) nargs))) - -(define (arg-list-valid? arglst) - (or (variable? arglst) - (and (or (list? arglst) (pair? arglst)) - (list-of? variable? arglst)))) - -(define (list-of? type lst) - (if (null? lst) #t - (if (type (car lst)) - (if (type (cdr lst)) #t (list-of? type (cdr lst))) - #f))) - -(define (variable? sym) - (and (symbol? sym) - (not (type-name? sym)) - (not (type-var? sym)))) - -(define (atomic-base-type? type) - (if (member type '(Any Number Symbol String Char Bool)) #t #f)) - -(define (type? expr) - (cond [(null? expr) #f] - [(member '-> expr) (fn-type? expr)] - [(list? expr) (and (> (length expr) 1) - (apply list-and? (map type? expr)))] - [else (or (type-name? expr) (type-var? expr))])) - -(define (type-name? sym) - (and (symbol? sym) - (let [(ch (string-ref (symbol->string sym) 0))] - (and (char>=? ch #\A) (char<=? ch #\Z))))) - -(define (type-var? sym) - (and (symbol? sym) - (let [(ch (string-ref (symbol->string sym) 0))] - (char=? ch #\?)))) - -(define (fn-type? expr) - (define (is-fn-type? prev expr) - (if (null? expr) #t - (case (car expr) - [(...) (and (type? prev) - (>= (length (cdr expr)) 1) - (equal? '-> (cadr expr)) - (is-fn-type? #f (cdr expr)))] - [(->) (and (= 2 (length expr)) - (is-fn-type? (car expr) (cdr expr)))] - [else (and (type? (car expr)) - (is-fn-type? (car expr) (cdr expr)))]))) - (is-fn-type? #f expr)) - -(define (list-and? . args) - (if (null? args) #t (and (car args) (apply list-and? (cdr args))))) - -; Main -;------------------------------------------------------------------------------ - -(define fail error) - -(define log-msg (lambda args '())) - -;(define (print-data . args) -; (apply print -; (map (lambda (e) -; (if (string? e) -; e -; (with-output-to-string (lambda () (pretty-print e))))) -; args))) - -;(define (interpret port) -; (call/cc (lambda (k) -; (set! fail k) -; (set! log-msg print) -; (display (string-append ":" (sexp-count) "> ")) -; ; Read and type and analyze all expressions from input -; (define expr (sclpl-read port)) -; (print-data "Read Phase: \n" expr) -; (set! expr (expand-macros expr)) -; (print-data "Macro Expansion Phase: \n" expr) -; (set! expr (desugar expr)) -; (print-data "Desugar Phase: \n" expr) -; (set! expr (analyze expr)) -; (print-data "Analysis Phase: \n" expr))) -; (interpret port)) -;(interpret (current-input-port)) -;(exit) - -(define (read-program port) - (define expr (sclpl-read port)) - (if (eof-object? expr) - '() - (cons (analyze (desugar (expand-macros expr))) - (read-program port)))) - -(print (read-program (current-input-port))) - - diff --git a/source/slpkg/main.scm b/source/slpkg/main.scm deleted file mode 100644 index 2d821a1..0000000 --- a/source/slpkg/main.scm +++ /dev/null @@ -1,72 +0,0 @@ -(declare (uses library server)) - -(define slpkg-usage -"Package manager for SCLPL (Simple Concurrent List Processing Language). - -Usage: - slpkg [COMMAND] [OPTIONS] - -Commands: - help Show help documentation for a specific command or subcommand. - install Install one or more packages from the configured sources. - publish Publish a package to a specified repository. - remove Remove one or more packages from this machine. - search Search the repositories for packages matching a pattern. - server Start a package server to host packages. - show Show detailed information about a specific package or packages. - source Manage the sources from which packages will be retrieved. - update Update the package lists for all configured sources. - upgrade Upgrade a given package or packages. -") - -;------------------------------------------------------------------------------ - -(define (help-cmd args) - (print args)) - -;------------------------------------------------------------------------------ -(define install-cmd help-cmd) -;------------------------------------------------------------------------------ -(define publish-cmd help-cmd) -;------------------------------------------------------------------------------ -(define remove-cmd help-cmd) -;------------------------------------------------------------------------------ -(define search-cmd help-cmd) -;------------------------------------------------------------------------------ - -(define (server-cmd args) - (start-pkg-server (cadr args) (caddr args))) - -;------------------------------------------------------------------------------ -(define show-cmd help-cmd) -;------------------------------------------------------------------------------ -(define source-cmd help-cmd) -;------------------------------------------------------------------------------ -(define update-cmd help-cmd) -;------------------------------------------------------------------------------ -(define upgrade-cmd help-cmd) -;------------------------------------------------------------------------------ - -(define slpkg-commands - `(("help" . ,help-cmd) - ("install" . ,install-cmd) - ("publish" . ,publish-cmd) - ("remove" . ,remove-cmd) - ("search" . ,search-cmd) - ("server" . ,server-cmd) - ("show" . ,show-cmd) - ("source" . ,source-cmd) - ("update" . ,update-cmd) - ("upgrade" . ,upgrade-cmd))) - -;------------------------------------------------------------------------------ - -(define (cmd-dispatch cmd-map usage args) - (define sub-cmd (if (pair? args) (assoc (car args) cmd-map) '())) - (cond [(pair? sub-cmd) ((cdr sub-cmd) (cdr args))] - [else (print usage)])) - -;------------------------------------------------------------------------------ - -(cmd-dispatch slpkg-commands slpkg-usage (command-line-arguments)) - diff --git a/source/slpkg/server.scm b/source/slpkg/server.scm deleted file mode 100644 index 9b33a38..0000000 --- a/source/slpkg/server.scm +++ /dev/null @@ -1,44 +0,0 @@ -(declare (unit server) (uses eval));(uses spiffy intarweb posix)) -(require-extension spiffy) - -(define index-template -" - - - Index of ~a - - -
~a
- -") - -(define entry-template "~a
\n") - -(define (html-response html) - (with-headers `((content-type text/html) - (content-length ,(string-length html))) - (lambda () - (write-logged-response) - (display html (response-port (current-response)))))) - -(define (generate-index path) - (define curr_root (string-append (root-path) path)) - (define entries (glob (string-append curr_root "/*"))) - (apply string-append - (map (lambda (e) - (define pth (if (equal? "/" path) path (string-append path "/" e))) - (sprintf entry-template pth e)) - (map (lambda (e) (car (reverse (string-split e "/")))) - entries)))) - -(define (index-handler path) - (html-response (sprintf index-template path (generate-index path)))) - -(define (start-pkg-server port root) - (server-port port) - (root-path root) - (handle-directory index-handler) - (start-server)) - -- 2.54.0