Slow_Lisp prototype update
This commit is contained in:
Jeremiah Orians
parent
f05b23ef34
commit
6f6dc7b48d
|
|
@ -19,6 +19,8 @@
|
|||
Added support for \f, \v and \e
|
||||
Added refresh to bootstrap.sh to build seed from cc_x86.s
|
||||
Added missing license headers
|
||||
Added support for ~expressions
|
||||
Added prototype for Slow_Lisp build test
|
||||
|
||||
** Changed
|
||||
Converted M2-Planet to use GNU style error message
|
||||
|
|
|
|||
|
|
@ -575,6 +575,11 @@ void primary_expr()
|
|||
common_recursion(postfix_expr);
|
||||
emit_out("XOR_ebx_eax_into_eax\n");
|
||||
}
|
||||
else if('~' == global_token->s[0])
|
||||
{
|
||||
common_recursion(postfix_expr);
|
||||
emit_out("NOT_eax\n");
|
||||
}
|
||||
else if(global_token->s[0] == '(')
|
||||
{
|
||||
global_token = global_token->next;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ a9a3e332d13ded5f80d7431f8717f26527b3722b33ea57760a9a5723dffc099c test/results/t
|
|||
f1c01feb865c4d552033186d9ce50dd39468a7e8aebf762886c13ad3e03b5011 test/results/test08-binary
|
||||
3b39e72f3de90ed690adfaf6145af46157cef2ec5e72867ac577fa27a0229894 test/results/test09-binary
|
||||
020e86020819cc4963e6185b22e534fcf8306b6cb116f12643f254a24688ff0a test/results/test10-binary
|
||||
a9708d6e40a4c00d7afe1163a9d149d46525071e9b8a0f283d82f76b443da182 test/results/test100-binary
|
||||
0c5850abb4ea2c4ba62005d6783b7b076baf86e2b960a806e10ee25dfc30b620 test/results/test100-binary
|
||||
3fd11bad4a426ce1ff8fd9c6d7d2b943effae9f3f5740b7376e426e9b0555851 test/results/test11-binary
|
||||
f98ab8e4bb35580e0dde96126d7a56aff66bda208d02c8d89390b40d6cff591c test/results/test12-binary
|
||||
5051ffca2615144419f8ec1a5d4999486ae81e7781428f59e47e866af97cef92 test/results/test13-binary
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
b882976ea4fb2ede866851a57fd3be0653ac1918b87e183e4c1cd6cb5c60d2b4 test/test100/proof
|
||||
b39435961127c9f5096e07a54c1aff13b02444d0ca07c61477558c1b1ff999a1 test/test100/proof
|
||||
|
|
|
|||
|
|
@ -0,0 +1,23 @@
|
|||
## Copyright (C) 2017 Jeremiah Orians
|
||||
## This file is part of M2-Planet.
|
||||
##
|
||||
## M2-Planet is free software: you can redistribute it and/or modify
|
||||
## it under the terms of the GNU General Public License as published by
|
||||
## the Free Software Foundation, either version 3 of the License, or
|
||||
## (at your option) any later version.
|
||||
##
|
||||
## M2-Planet is distributed in the hope that it will be useful,
|
||||
## but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
## GNU General Public License for more details.
|
||||
##
|
||||
## You should have received a copy of the GNU General Public License
|
||||
## along with M2-Planet. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
# Ignore the files created by script
|
||||
*.M1
|
||||
*.hex2
|
||||
proof
|
||||
|
||||
# A place to put a good run for comparison
|
||||
actual.M1
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
#! /bin/sh
|
||||
## Copyright (C) 2017 Jeremiah Orians
|
||||
## This file is part of M2-Planet.
|
||||
##
|
||||
## M2-Planet is free software: you can redistribute it and/or modify
|
||||
## it under the terms of the GNU General Public License as published by
|
||||
## the Free Software Foundation, either version 3 of the License, or
|
||||
## (at your option) any later version.
|
||||
##
|
||||
## M2-Planet is distributed in the hope that it will be useful,
|
||||
## but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
## GNU General Public License for more details.
|
||||
##
|
||||
## You should have received a copy of the GNU General Public License
|
||||
## along with M2-Planet. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
rm -f test/test26/lisp.M1
|
||||
rm -f test/test26/lisp-footer.M1
|
||||
rm -f test/test26/lisp.hex2
|
||||
rm -f test/test26/proof
|
||||
exit 0
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
/* Copyright (C) 2016 Jeremiah Orians
|
||||
* This file is part of stage0.
|
||||
*
|
||||
* stage0 is free software: you can redistribute it and/or modify
|
||||
* it under the terms of the GNU General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or
|
||||
* (at your option) any later version.
|
||||
*
|
||||
* stage0 is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with stage0. If not, see <http://www.gnu.org/licenses/>.
|
||||
*/
|
||||
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
|
||||
typedef struct cell* (FUNCTION)(struct cell *);
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
#! /bin/sh
|
||||
## Copyright (C) 2017 Jeremiah Orians
|
||||
## This file is part of M2-Planet.
|
||||
##
|
||||
## M2-Planet is free software: you can redistribute it and/or modify
|
||||
## it under the terms of the GNU General Public License as published by
|
||||
## the Free Software Foundation, either version 3 of the License, or
|
||||
## (at your option) any later version.
|
||||
##
|
||||
## M2-Planet is distributed in the hope that it will be useful,
|
||||
## but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
## GNU General Public License for more details.
|
||||
##
|
||||
## You should have received a copy of the GNU General Public License
|
||||
## along with M2-Planet. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
set -x
|
||||
# Build the test
|
||||
./bin/M2-Planet -f test/test26/lisp.h \
|
||||
-f functions/malloc.c \
|
||||
-f functions/calloc.c \
|
||||
-f functions/numerate_number.c \
|
||||
-f functions/match.c \
|
||||
-f functions/file.c \
|
||||
-f functions/file_print.c \
|
||||
-f functions/exit.c \
|
||||
-f test/test26/lisp.c \
|
||||
-f test/test26/lisp_cell.c \
|
||||
-f test/test26/lisp_eval.c \
|
||||
-f test/test26/lisp_print.c \
|
||||
-f test/test26/lisp_read.c \
|
||||
--debug \
|
||||
-o test/test26/lisp.M1 || exit 1
|
||||
|
||||
# Build debug footer
|
||||
blood-elf -f test/test26/lisp.M1 \
|
||||
-o test/test26/lisp-footer.M1 || exit 2
|
||||
|
||||
# Macro assemble with libc written in M1-Macro
|
||||
M1 -f test/common_x86/x86_defs.M1 \
|
||||
-f functions/libc-core.M1 \
|
||||
-f test/test26/lisp.M1 \
|
||||
-f test/test26/lisp-footer.M1 \
|
||||
--LittleEndian \
|
||||
--Architecture 1 \
|
||||
-o test/test26/lisp.hex2 || exit 3
|
||||
|
||||
# Resolve all linkages
|
||||
hex2 -f test/common_x86/ELF-i386-debug.hex2 \
|
||||
-f test/test26/lisp.hex2 \
|
||||
--LittleEndian \
|
||||
--Architecture 1 \
|
||||
--BaseAddress 0x8048000 \
|
||||
-o test/results/test26-binary \
|
||||
--exec_enable || exit 4
|
||||
|
||||
exit 0
|
||||
|
|
@ -0,0 +1,161 @@
|
|||
/* Copyright (C) 2016 Jeremiah Orians
|
||||
* This file is part of stage0.
|
||||
*
|
||||
* stage0 is free software: you can redistribute it and/or modify
|
||||
* it under the terms of the GNU General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or
|
||||
* (at your option) any later version.
|
||||
*
|
||||
* stage0 is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with stage0. If not, see <http://www.gnu.org/licenses/>.
|
||||
*/
|
||||
|
||||
#include "lisp.h"
|
||||
|
||||
struct file_list
|
||||
{
|
||||
struct file_list* next;
|
||||
FILE* file;
|
||||
};
|
||||
|
||||
/* Prototypes */
|
||||
struct cell* eval(struct cell* exp, struct cell* env);
|
||||
void init_sl3();
|
||||
int Readline(FILE* source_file, char* temp);
|
||||
struct cell* parse(char* program, int size);
|
||||
void writeobj(FILE *ofp, struct cell* op);
|
||||
void garbage_init(int number_of_cells);
|
||||
void garbage_collect();
|
||||
|
||||
/* Read Eval Print Loop*/
|
||||
int REPL(FILE* in, FILE *out)
|
||||
{
|
||||
int read;
|
||||
input = in;
|
||||
char* message = calloc(MAX_STRING + 2, sizeof(char));
|
||||
read = Readline(in, message);
|
||||
if(0 == read)
|
||||
{
|
||||
return TRUE;
|
||||
}
|
||||
struct cell* temp = parse(message, read);
|
||||
current = temp;
|
||||
temp = eval(temp, top_env);
|
||||
writeobj(out, temp);
|
||||
current = nil;
|
||||
if(echo) fputc('\n', out);
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
void recursively_evaluate(struct file_list* a)
|
||||
{
|
||||
if(NULL == a) return;
|
||||
recursively_evaluate(a->next);
|
||||
int Reached_EOF = FALSE;
|
||||
while(!Reached_EOF)
|
||||
{
|
||||
garbage_collect();
|
||||
Reached_EOF = REPL(a->file, console_output);
|
||||
}
|
||||
}
|
||||
|
||||
/*** Main Driver ***/
|
||||
int main(int argc, char **argv)
|
||||
{
|
||||
int number_of_cells = 1000000;
|
||||
file_output = fopen("/dev/null", "w");
|
||||
console_output = stdout;
|
||||
struct file_list* essential = NULL;
|
||||
|
||||
int i = 1;
|
||||
while(i <= argc)
|
||||
{
|
||||
if(NULL == argv[i])
|
||||
{
|
||||
i = i + 1;
|
||||
}
|
||||
else if(match(argv[i], "-c") || match(argv[i], "--console"))
|
||||
{
|
||||
console_output = fopen(argv[i + 1], "w");
|
||||
if(NULL == console_output)
|
||||
{
|
||||
file_print("The file: ", stderr);
|
||||
file_print(argv[i + 1], stderr);
|
||||
file_print(" does not appear writable\n", stderr);
|
||||
exit(EXIT_FAILURE);
|
||||
}
|
||||
i = i + 2;
|
||||
}
|
||||
else if(match(argv[i], "-f") || match(argv[i], "--file"))
|
||||
{
|
||||
struct file_list* new = calloc(1, sizeof(struct file_list));
|
||||
new->file = fopen(argv[i + 1], "r");
|
||||
if(NULL == new->file)
|
||||
{
|
||||
file_print("The file: ", stderr);
|
||||
file_print(argv[i + 1], stderr);
|
||||
file_print(" does not appear readable\n", stderr);
|
||||
exit(EXIT_FAILURE);
|
||||
}
|
||||
new->next = essential;
|
||||
essential = new;
|
||||
i = i + 2;
|
||||
}
|
||||
else if(match(argv[i], "-h") || match(argv[i], "--help"))
|
||||
{
|
||||
file_print("Usage: ", stdout);
|
||||
file_print(argv[0], stdout);
|
||||
file_print(" -f FILENAME1 {-f FILENAME2}\n", stdout);
|
||||
exit(EXIT_SUCCESS);
|
||||
}
|
||||
else if(match(argv[i], "-m") || match(argv[i], "--memory"))
|
||||
{
|
||||
number_of_cells = numerate_string(argv[i + 1]);
|
||||
i = i + 2;
|
||||
}
|
||||
else if(match(argv[i], "-o") || match(argv[i], "--output"))
|
||||
{
|
||||
file_output = fopen(argv[i + 1], "w");
|
||||
if(NULL == file_output)
|
||||
{
|
||||
file_print("The file: ", stderr);
|
||||
file_print(argv[i + 1], stderr);
|
||||
file_print(" does not appear writable\n", stderr);
|
||||
exit(EXIT_FAILURE);
|
||||
}
|
||||
i = i + 2;
|
||||
}
|
||||
else if(match(argv[i], "-v") || match(argv[i], "--version"))
|
||||
{
|
||||
file_print("Slow_Lisp 0.1\n", stdout);
|
||||
exit(EXIT_SUCCESS);
|
||||
}
|
||||
else
|
||||
{
|
||||
file_print("Unknown option\n", stderr);
|
||||
exit(EXIT_FAILURE);
|
||||
}
|
||||
}
|
||||
|
||||
/* Our most important initializations */
|
||||
garbage_init(number_of_cells);
|
||||
init_sl3();
|
||||
int Reached_EOF;
|
||||
echo = TRUE;
|
||||
|
||||
recursively_evaluate(essential);
|
||||
|
||||
Reached_EOF = FALSE;
|
||||
while(!Reached_EOF)
|
||||
{
|
||||
garbage_collect();
|
||||
Reached_EOF = REPL(stdin, stdout);
|
||||
}
|
||||
fclose(file_output);
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -0,0 +1,87 @@
|
|||
/* Copyright (C) 2016 Jeremiah Orians
|
||||
* This file is part of stage0.
|
||||
*
|
||||
* stage0 is free software: you can redistribute it and/or modify
|
||||
* it under the terms of the GNU General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or
|
||||
* (at your option) any later version.
|
||||
*
|
||||
* stage0 is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with stage0. If not, see <http://www.gnu.org/licenses/>.
|
||||
*/
|
||||
|
||||
#include "gcc_req.h"
|
||||
|
||||
//CONSTANT FREE 1
|
||||
#define FREE 1
|
||||
//CONSTANT MARKED 2
|
||||
#define MARKED 2
|
||||
//CONSTANT INT 4
|
||||
#define INT 4
|
||||
//CONSTANT SYM 8
|
||||
#define SYM 8
|
||||
//CONSTANT CONS 16
|
||||
#define CONS 16
|
||||
//CONSTANT PROC 32
|
||||
#define PROC 32
|
||||
//CONSTANT PRIMOP 64
|
||||
#define PRIMOP 64
|
||||
//CONSTANT CHAR 128
|
||||
#define CHAR 128
|
||||
//CONSTANT STRING 256
|
||||
#define STRING 256
|
||||
|
||||
// CONSTANT FALSE 0
|
||||
#define FALSE 0
|
||||
// CONSTANT TRUE 1
|
||||
#define TRUE 1
|
||||
|
||||
struct cell
|
||||
{
|
||||
int type;
|
||||
union
|
||||
{
|
||||
struct cell* car;
|
||||
int value;
|
||||
char* string;
|
||||
FUNCTION* function;
|
||||
};
|
||||
struct cell* cdr;
|
||||
struct cell* env;
|
||||
};
|
||||
|
||||
// CONSTANT MAX_STRING 4096
|
||||
#define MAX_STRING 4096
|
||||
|
||||
/* Common functions */
|
||||
struct cell* make_cons(struct cell* a, struct cell* b);
|
||||
int numerate_string(char *a);
|
||||
char* numerate_number(int a);
|
||||
int match(char* a, char* b);
|
||||
void file_print(char* s, FILE* f);
|
||||
|
||||
/* Global objects */
|
||||
struct cell *all_symbols;
|
||||
struct cell *top_env;
|
||||
struct cell *nil;
|
||||
struct cell *tee;
|
||||
struct cell *quote;
|
||||
struct cell *s_if;
|
||||
struct cell *s_lambda;
|
||||
struct cell *s_define;
|
||||
struct cell *s_setb;
|
||||
struct cell *s_cond;
|
||||
struct cell *s_begin;
|
||||
struct cell *s_let;
|
||||
struct cell *s_while;
|
||||
struct cell *current;
|
||||
FILE* input;
|
||||
FILE* file_output;
|
||||
FILE* console_output;
|
||||
int echo;
|
||||
int left_to_take;
|
||||
|
|
@ -0,0 +1,261 @@
|
|||
/* Copyright (C) 2016 Jeremiah Orians
|
||||
* This file is part of stage0.
|
||||
*
|
||||
* stage0 is free software: you can redistribute it and/or modify
|
||||
* it under the terms of the GNU General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or
|
||||
* (at your option) any later version.
|
||||
*
|
||||
* stage0 is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with stage0. If not, see <http://www.gnu.org/licenses/>.
|
||||
*/
|
||||
|
||||
#include "lisp.h"
|
||||
|
||||
/* Deal with the fact GCC converts the 1 to the size of the structs being iterated over */
|
||||
#define CELL_SIZE 1
|
||||
//CONSTANT CELL_SIZE 16
|
||||
|
||||
struct cell *free_cells;
|
||||
struct cell *gc_block_start;
|
||||
struct cell *top_allocated;
|
||||
|
||||
void update_remaining()
|
||||
{
|
||||
int count = 0;
|
||||
struct cell* i = free_cells;
|
||||
while(NULL != i)
|
||||
{
|
||||
count = count + 1;
|
||||
i = i->cdr;
|
||||
}
|
||||
left_to_take = count;
|
||||
}
|
||||
|
||||
struct cell* insert_ordered(struct cell* i, struct cell* list)
|
||||
{
|
||||
if(NULL == list)
|
||||
{
|
||||
return i;
|
||||
}
|
||||
|
||||
if(i < list)
|
||||
{
|
||||
i->cdr = list;
|
||||
return i;
|
||||
}
|
||||
|
||||
list->cdr = insert_ordered(i, list->cdr);
|
||||
return list;
|
||||
}
|
||||
|
||||
void reclaim_marked()
|
||||
{
|
||||
struct cell* i;
|
||||
for(i= top_allocated; i >= gc_block_start ; i = i - CELL_SIZE)
|
||||
{
|
||||
if(i->type & MARKED)
|
||||
{
|
||||
i->type = FREE;
|
||||
i->car = NULL;
|
||||
i->cdr = NULL;
|
||||
i->env = NULL;
|
||||
free_cells = insert_ordered(i, free_cells);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
void relocate_cell(struct cell* current, struct cell* target, struct cell* list)
|
||||
{
|
||||
for(; NULL != list; list = list->cdr)
|
||||
{
|
||||
if(list->car == current)
|
||||
{
|
||||
list->car = target;
|
||||
}
|
||||
|
||||
if(list->cdr == current)
|
||||
{
|
||||
list->cdr = target;
|
||||
}
|
||||
|
||||
if(list->env == current)
|
||||
{
|
||||
list->env = target;
|
||||
}
|
||||
|
||||
if((list->type & CONS)|| list->type & PROC )
|
||||
{
|
||||
relocate_cell(current, target, list->car);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
struct cell* pop_cons();
|
||||
void compact(struct cell* list)
|
||||
{
|
||||
for(; NULL != list; list = list->cdr)
|
||||
{
|
||||
if((FREE != list->type) && (list > free_cells ))
|
||||
{
|
||||
struct cell* temp = pop_cons();
|
||||
temp->type = list->type;
|
||||
temp->car = list->car;
|
||||
temp->cdr = list->cdr;
|
||||
temp->env = list->env;
|
||||
relocate_cell(list, temp, all_symbols);
|
||||
relocate_cell(list, temp, top_env);
|
||||
}
|
||||
|
||||
if((list->type & CONS)|| list->type & PROC )
|
||||
{
|
||||
compact(list->car);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
void mark_all_cells()
|
||||
{
|
||||
struct cell* i;
|
||||
for(i= gc_block_start; i < top_allocated; i = i + CELL_SIZE)
|
||||
{
|
||||
/* if not in the free list */
|
||||
if(!(i->type & FREE))
|
||||
{
|
||||
/* Mark it */
|
||||
i->type = i->type | MARKED;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
void unmark_cells(struct cell* list, struct cell* stop, int count)
|
||||
{
|
||||
if(count > 1) return;
|
||||
|
||||
for(; NULL != list; list = list->cdr)
|
||||
{
|
||||
if(list == stop) count = count + 1;
|
||||
list->type = list->type & ~MARKED;
|
||||
|
||||
if(list->type & PROC)
|
||||
{
|
||||
unmark_cells(list->car, stop, count);
|
||||
if(NULL != list->env)
|
||||
{
|
||||
unmark_cells(list->env, stop, count);
|
||||
}
|
||||
}
|
||||
|
||||
if(list->type & CONS)
|
||||
{
|
||||
unmark_cells(list->car, stop, count);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
void garbage_collect()
|
||||
{
|
||||
mark_all_cells();
|
||||
unmark_cells(current, current, 0);
|
||||
unmark_cells(all_symbols, all_symbols, 0);
|
||||
unmark_cells(top_env, top_env, 0);
|
||||
reclaim_marked();
|
||||
update_remaining();
|
||||
compact(all_symbols);
|
||||
compact(top_env);
|
||||
top_allocated = NULL;
|
||||
}
|
||||
|
||||
void garbage_init(int number_of_cells)
|
||||
{
|
||||
gc_block_start = calloc(number_of_cells + 1, sizeof(struct cell));
|
||||
top_allocated = gc_block_start + number_of_cells;
|
||||
free_cells = NULL;
|
||||
garbage_collect();
|
||||
top_allocated = NULL;
|
||||
}
|
||||
|
||||
struct cell* pop_cons()
|
||||
{
|
||||
if(NULL == free_cells)
|
||||
{
|
||||
file_print("OOOPS we ran out of cells", stderr);
|
||||
exit(EXIT_FAILURE);
|
||||
}
|
||||
struct cell* i;
|
||||
i = free_cells;
|
||||
free_cells = i->cdr;
|
||||
i->cdr = NULL;
|
||||
if(i > top_allocated)
|
||||
{
|
||||
top_allocated = i;
|
||||
}
|
||||
left_to_take = left_to_take - 1;
|
||||
return i;
|
||||
}
|
||||
|
||||
struct cell* make_cell(int type, struct cell* a, struct cell* b, struct cell* env)
|
||||
{
|
||||
struct cell* c = pop_cons();
|
||||
c->type = type;
|
||||
c->car = a;
|
||||
c->cdr = b;
|
||||
c->env = env;
|
||||
return c;
|
||||
}
|
||||
|
||||
struct cell* make_int(int a)
|
||||
{
|
||||
struct cell* c = pop_cons();
|
||||
c->type = INT;
|
||||
c->value = a;
|
||||
return c;
|
||||
}
|
||||
|
||||
struct cell* make_char(int a)
|
||||
{
|
||||
struct cell* c = pop_cons();
|
||||
c->type = CHAR;
|
||||
c->value = a;
|
||||
return c;
|
||||
}
|
||||
|
||||
struct cell* make_string(char* a)
|
||||
{
|
||||
struct cell* c = pop_cons();
|
||||
c->type = STRING;
|
||||
c->string = a;
|
||||
return c;
|
||||
}
|
||||
|
||||
struct cell* make_sym(char* name)
|
||||
{
|
||||
struct cell* c = pop_cons();
|
||||
c->type = SYM;
|
||||
c->string = name;
|
||||
return c;
|
||||
}
|
||||
|
||||
struct cell* make_cons(struct cell* a, struct cell* b)
|
||||
{
|
||||
return make_cell(CONS, a, b, nil);
|
||||
}
|
||||
|
||||
struct cell* make_proc(struct cell* a, struct cell* b, struct cell* env)
|
||||
{
|
||||
return make_cell(PROC, a, b, env);
|
||||
}
|
||||
|
||||
struct cell* make_prim(void* fun)
|
||||
{
|
||||
struct cell* c = pop_cons();
|
||||
c->type = PRIMOP;
|
||||
c->function = fun;
|
||||
return c;
|
||||
}
|
||||
|
|
@ -0,0 +1,643 @@
|
|||
/* Copyright (C) 2016 Jeremiah Orians
|
||||
* This file is part of stage0.
|
||||
*
|
||||
* stage0 is free software: you can redistribute it and/or modify
|
||||
* it under the terms of the GNU General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or
|
||||
* (at your option) any later version.
|
||||
*
|
||||
* stage0 is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with stage0. If not, see <http://www.gnu.org/licenses/>.
|
||||
*/
|
||||
|
||||
#include "lisp.h"
|
||||
|
||||
/* Support functions */
|
||||
struct cell* findsym(char *name)
|
||||
{
|
||||
struct cell* symlist;
|
||||
for(symlist = all_symbols; nil != symlist; symlist = symlist->cdr)
|
||||
{
|
||||
if(match(name, symlist->car->string))
|
||||
{
|
||||
return symlist;
|
||||
}
|
||||
}
|
||||
return nil;
|
||||
}
|
||||
|
||||
struct cell* make_sym(char* name);
|
||||
|
||||
struct cell* intern(char *name)
|
||||
{
|
||||
struct cell* op = findsym(name);
|
||||
if(nil != op) return op->car;
|
||||
op = make_sym(name);
|
||||
all_symbols = make_cons(op, all_symbols);
|
||||
return op;
|
||||
}
|
||||
|
||||
/*** Environment ***/
|
||||
struct cell* extend(struct cell* env, struct cell* symbol, struct cell* value)
|
||||
{
|
||||
return make_cons(make_cons(symbol, value), env);
|
||||
}
|
||||
|
||||
struct cell* multiple_extend(struct cell* env, struct cell* syms, struct cell* vals)
|
||||
{
|
||||
if(nil == syms)
|
||||
{
|
||||
return env;
|
||||
}
|
||||
return multiple_extend(extend(env, syms->car, vals->car), syms->cdr, vals->cdr);
|
||||
}
|
||||
|
||||
struct cell* extend_env(struct cell* sym, struct cell* val, struct cell* env)
|
||||
{
|
||||
env->cdr = make_cons(env->car, env->cdr);
|
||||
env->car = make_cons(sym, val);
|
||||
return val;
|
||||
}
|
||||
|
||||
struct cell* assoc(struct cell* key, struct cell* alist)
|
||||
{
|
||||
if(nil == alist) return nil;
|
||||
for(; nil != alist; alist = alist->cdr)
|
||||
{
|
||||
if(alist->car->car->string == key->string) return alist->car;
|
||||
}
|
||||
return nil;
|
||||
}
|
||||
|
||||
/*** Evaluator (Eval/Apply) ***/
|
||||
struct cell* eval(struct cell* exp, struct cell* env);
|
||||
struct cell* make_proc(struct cell* a, struct cell* b, struct cell* env);
|
||||
struct cell* evlis(struct cell* exps, struct cell* env)
|
||||
{
|
||||
if(exps == nil) return nil;
|
||||
return make_cons(eval(exps->car, env), evlis(exps->cdr, env));
|
||||
}
|
||||
|
||||
struct cell* progn(struct cell* exps, struct cell* env)
|
||||
{
|
||||
if(exps == nil) return nil;
|
||||
|
||||
struct cell* result;
|
||||
progn_reset:
|
||||
result = eval(exps->car, env);
|
||||
if(exps->cdr == nil) return result;
|
||||
exps = exps->cdr;
|
||||
goto progn_reset;
|
||||
}
|
||||
|
||||
struct cell* exec_func(FUNCTION * func, struct cell* vals)
|
||||
{
|
||||
return func(vals);
|
||||
}
|
||||
|
||||
struct cell* apply(struct cell* proc, struct cell* vals)
|
||||
{
|
||||
struct cell* temp = nil;
|
||||
if(proc->type == PRIMOP)
|
||||
{
|
||||
temp = exec_func(proc->function, vals);
|
||||
}
|
||||
else if(proc->type == PROC)
|
||||
{
|
||||
struct cell* env = make_cons(proc->env->car, proc->env->cdr);
|
||||
temp = progn(proc->cdr, multiple_extend(env, proc->car, vals));
|
||||
}
|
||||
else
|
||||
{
|
||||
file_print("Bad argument to apply\n", stderr);
|
||||
exit(EXIT_FAILURE);
|
||||
}
|
||||
return temp;
|
||||
}
|
||||
|
||||
struct cell* evcond(struct cell* exp, struct cell* env)
|
||||
{
|
||||
/* Return nil but the result is technically undefined per the standard */
|
||||
if(nil == exp)
|
||||
{
|
||||
return nil;
|
||||
}
|
||||
|
||||
if(tee == eval(exp->car->car, env))
|
||||
{
|
||||
return eval(exp->car->cdr->car, env);
|
||||
}
|
||||
|
||||
return evcond(exp->cdr, env);
|
||||
}
|
||||
|
||||
void garbage_collect();
|
||||
struct cell* evwhile(struct cell* exp, struct cell* env)
|
||||
{
|
||||
if(nil == exp) return nil;
|
||||
struct cell* conditional = eval(exp->cdr->car, env);
|
||||
|
||||
while(tee == conditional)
|
||||
{
|
||||
eval(exp->cdr->cdr->car, env);
|
||||
conditional = eval(exp->cdr->car, env);
|
||||
if((tee == exp->cdr->car) && (left_to_take < 1000)) garbage_collect();
|
||||
}
|
||||
|
||||
return conditional;
|
||||
}
|
||||
|
||||
struct cell* process_sym(struct cell* exp, struct cell* env);
|
||||
struct cell* process_cons(struct cell* exp, struct cell* env);
|
||||
|
||||
struct cell* eval(struct cell* exp, struct cell* env)
|
||||
{
|
||||
if(exp == nil) return nil;
|
||||
if(SYM == exp->type) return process_sym(exp, env);
|
||||
if(CONS == exp->type) return process_cons(exp, env);
|
||||
return exp;
|
||||
}
|
||||
|
||||
struct cell* process_sym(struct cell* exp, struct cell* env)
|
||||
{
|
||||
struct cell* tmp = assoc(exp, env);
|
||||
if(tmp == nil)
|
||||
{
|
||||
file_print("Unbound symbol:", stderr);
|
||||
file_print(exp->string, stderr);
|
||||
fputc('\n', stderr);
|
||||
exit(EXIT_FAILURE);
|
||||
}
|
||||
return tmp->cdr;
|
||||
}
|
||||
|
||||
struct cell* process_if(struct cell* exp, struct cell* env)
|
||||
{
|
||||
if(eval(exp->cdr->car, env) != nil)
|
||||
{
|
||||
return eval(exp->cdr->cdr->car, env);
|
||||
}
|
||||
return eval(exp->cdr->cdr->cdr->car, env);
|
||||
|
||||
}
|
||||
|
||||
struct cell* process_setb(struct cell* exp, struct cell* env)
|
||||
{
|
||||
struct cell* newval = eval(exp->cdr->cdr->car, env);
|
||||
struct cell* pair = assoc(exp->cdr->car, env);
|
||||
pair->cdr = newval;
|
||||
return newval;
|
||||
}
|
||||
|
||||
struct cell* process_let(struct cell* exp, struct cell* env)
|
||||
{
|
||||
struct cell* lets;
|
||||
for(lets = exp->cdr->car; lets != nil; lets = lets->cdr)
|
||||
{
|
||||
env = make_cons(make_cons(lets->car->car, eval(lets->car->cdr->car, env)), env);
|
||||
}
|
||||
return progn(exp->cdr->cdr, env);
|
||||
}
|
||||
|
||||
struct cell* process_cons(struct cell* exp, struct cell* env)
|
||||
{
|
||||
if(exp->car == s_if) return process_if(exp, env);
|
||||
if(exp->car == s_cond) return evcond(exp->cdr, env);
|
||||
if(exp->car == s_begin) return progn(exp->cdr, env);
|
||||
if(exp->car == s_lambda) return make_proc(exp->cdr->car, exp->cdr->cdr, env);
|
||||
if(exp->car == quote) return exp->cdr->car;
|
||||
if(exp->car == s_define) return(extend_env(exp->cdr->car, eval(exp->cdr->cdr->car, env), env));
|
||||
if(exp->car == s_setb) return process_setb(exp, env);
|
||||
if(exp->car == s_let) return process_let(exp, env);
|
||||
if(exp->car == s_while) return evwhile(exp, env);
|
||||
return apply(eval(exp->car, env), evlis(exp->cdr, env));
|
||||
}
|
||||
|
||||
|
||||
/*** Primitives ***/
|
||||
struct cell* prim_apply(struct cell* args)
|
||||
{
|
||||
return apply(args->car, args->cdr->car);
|
||||
}
|
||||
|
||||
struct cell* nullp(struct cell* args)
|
||||
{
|
||||
if(nil == args->car) return tee;
|
||||
return nil;
|
||||
}
|
||||
|
||||
struct cell* make_int(int a);
|
||||
struct cell* prim_sum(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
int sum;
|
||||
for(sum = 0; nil != args; args = args->cdr)
|
||||
{
|
||||
sum = sum + args->car->value;
|
||||
}
|
||||
return make_int(sum);
|
||||
}
|
||||
|
||||
struct cell* prim_sub(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
int sum = args->car->value;
|
||||
for(args = args->cdr; nil != args; args = args->cdr)
|
||||
{
|
||||
sum = sum - args->car->value;
|
||||
}
|
||||
return make_int(sum);
|
||||
}
|
||||
|
||||
struct cell* prim_prod(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
int prod;
|
||||
for(prod = 1; nil != args; args = args->cdr)
|
||||
{
|
||||
prod = prod * args->car->value;
|
||||
}
|
||||
return make_int(prod);
|
||||
}
|
||||
|
||||
struct cell* prim_div(struct cell* args)
|
||||
{
|
||||
if(nil == args) return make_int(1);
|
||||
|
||||
int div = args->car->value;
|
||||
for(args = args->cdr; nil != args; args = args->cdr)
|
||||
{
|
||||
div = div / args->car->value;
|
||||
}
|
||||
return make_int(div);
|
||||
}
|
||||
|
||||
struct cell* prim_mod(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
int mod = args->car->value % args->cdr->car->value;
|
||||
if(nil != args->cdr->cdr)
|
||||
{
|
||||
file_print("wrong number of arguments to mod\n", stderr);
|
||||
exit(EXIT_FAILURE);
|
||||
}
|
||||
return make_int(mod);
|
||||
}
|
||||
|
||||
struct cell* prim_and(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
for(; nil != args; args = args->cdr)
|
||||
{
|
||||
if(tee != args->car) return nil;
|
||||
}
|
||||
return tee;
|
||||
}
|
||||
|
||||
struct cell* prim_or(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
for(; nil != args; args = args->cdr)
|
||||
{
|
||||
if(tee == args->car) return tee;
|
||||
}
|
||||
return nil;
|
||||
}
|
||||
|
||||
struct cell* prim_not(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
if(tee != args->car) return tee;
|
||||
return nil;
|
||||
}
|
||||
|
||||
struct cell* prim_numgt(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
int temp = args->car->value;
|
||||
for(args = args->cdr; nil != args; args = args->cdr)
|
||||
{
|
||||
if(temp <= args->car->value)
|
||||
{
|
||||
return nil;
|
||||
}
|
||||
temp = args->car->value;
|
||||
}
|
||||
return tee;
|
||||
}
|
||||
|
||||
struct cell* prim_numge(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
int temp = args->car->value;
|
||||
for(args = args->cdr; nil != args; args = args->cdr)
|
||||
{
|
||||
if(temp < args->car->value)
|
||||
{
|
||||
return nil;
|
||||
}
|
||||
temp = args->car->value;
|
||||
}
|
||||
return tee;
|
||||
}
|
||||
|
||||
struct cell* prim_numeq(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
int temp = args->car->value;
|
||||
for(args = args->cdr; nil != args; args = args->cdr)
|
||||
{
|
||||
if(temp != args->car->value)
|
||||
{
|
||||
return nil;
|
||||
}
|
||||
}
|
||||
return tee;
|
||||
}
|
||||
|
||||
struct cell* prim_numle(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
int temp = args->car->value;
|
||||
for(args = args->cdr; nil != args; args = args->cdr)
|
||||
{
|
||||
if(temp > args->car->value)
|
||||
{
|
||||
return nil;
|
||||
}
|
||||
temp = args->car->value;
|
||||
}
|
||||
return tee;
|
||||
}
|
||||
|
||||
struct cell* prim_numlt(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
int temp = args->car->value;
|
||||
for(args = args->cdr; nil != args; args = args->cdr)
|
||||
{
|
||||
if(temp >= args->car->value)
|
||||
{
|
||||
return nil;
|
||||
}
|
||||
temp = args->car->value;
|
||||
}
|
||||
return tee;
|
||||
}
|
||||
|
||||
struct cell* prim_listp(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
if(CONS == args->car->type)
|
||||
{
|
||||
return tee;
|
||||
}
|
||||
return nil;
|
||||
}
|
||||
|
||||
struct cell* prim_get_type(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
return make_int(args->car->type);
|
||||
}
|
||||
|
||||
struct cell* make_cell(int type, struct cell* a, struct cell* b, struct cell* env);
|
||||
struct cell* prim_set_type(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
return make_cell(args->cdr->car->value, args->car->car, args->car->cdr, args->car->env);
|
||||
}
|
||||
|
||||
struct cell* prim_output(struct cell* args, FILE* out)
|
||||
{
|
||||
for(; nil != args; args = args->cdr)
|
||||
{
|
||||
if(INT == args->car->type)
|
||||
{
|
||||
file_print(numerate_number(args->car->value), out);
|
||||
}
|
||||
else if(CHAR == args->car->type)
|
||||
{
|
||||
fputc(args->car->value, out);
|
||||
}
|
||||
else if(CONS == args->car->type)
|
||||
{
|
||||
prim_output(args->car, out);
|
||||
}
|
||||
else
|
||||
{
|
||||
file_print(args->car->string, out);
|
||||
}
|
||||
}
|
||||
return tee;
|
||||
}
|
||||
|
||||
struct cell* prim_stringeq(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
char* temp = args->car->string;
|
||||
for(args = args->cdr; nil != args; args = args->cdr)
|
||||
{
|
||||
if(!match(temp, args->car->string))
|
||||
{
|
||||
return nil;
|
||||
}
|
||||
}
|
||||
return tee;
|
||||
}
|
||||
|
||||
struct cell* prim_display(struct cell* args)
|
||||
{
|
||||
return prim_output(args, console_output);
|
||||
}
|
||||
|
||||
struct cell* prim_write(struct cell* args)
|
||||
{
|
||||
return prim_output(args, file_output);
|
||||
}
|
||||
|
||||
struct cell* prim_freecell(struct cell* args)
|
||||
{
|
||||
if(nil == args)
|
||||
{
|
||||
file_print("Remaining Cells: ", stdout);
|
||||
file_print(numerate_number(left_to_take), stdout);
|
||||
return nil;
|
||||
}
|
||||
return make_int(left_to_take);
|
||||
}
|
||||
|
||||
struct cell* make_char(int a);
|
||||
struct cell* string_to_list(char* string)
|
||||
{
|
||||
if(NULL == string) return nil;
|
||||
if(0 == string[0]) return nil;
|
||||
struct cell* result = make_char(string[0]);
|
||||
struct cell* tail = string_to_list(string + 1);
|
||||
return make_cons(result, tail);
|
||||
}
|
||||
|
||||
struct cell* prim_string_to_list(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
|
||||
if(STRING == args->car->type)
|
||||
{
|
||||
return string_to_list(args->car->string);
|
||||
}
|
||||
return nil;
|
||||
}
|
||||
|
||||
struct cell* make_string(char* a);
|
||||
int list_to_string(int index, char* string, struct cell* args)
|
||||
{
|
||||
struct cell* i;
|
||||
for(i = args; nil != i; i = i->cdr)
|
||||
{
|
||||
if(CHAR == i->car->type)
|
||||
{
|
||||
string[index] = i->car->value;
|
||||
index = index + 1;
|
||||
}
|
||||
if(CONS == i->car->type)
|
||||
{
|
||||
index = list_to_string(index, string, i->car);
|
||||
}
|
||||
}
|
||||
return index;
|
||||
}
|
||||
|
||||
struct cell* prim_list_to_string(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
char* string = calloc(MAX_STRING + 2, sizeof(char));
|
||||
list_to_string(0, string, args);
|
||||
return make_string(string);
|
||||
}
|
||||
|
||||
struct cell* prim_echo(struct cell* args)
|
||||
{
|
||||
if(nil == args) return nil;
|
||||
if(nil == args->car) echo = FALSE;
|
||||
if(tee == args->car)
|
||||
{
|
||||
echo = TRUE;
|
||||
return make_string("");
|
||||
}
|
||||
return args->car;
|
||||
}
|
||||
|
||||
struct cell* prim_read_byte(struct cell* args)
|
||||
{
|
||||
if(nil == args) return make_char(fgetc(input));
|
||||
return nil;
|
||||
}
|
||||
|
||||
struct cell* prim_halt(struct cell* args)
|
||||
{
|
||||
/* Cleanup */
|
||||
free(args);
|
||||
fclose(file_output);
|
||||
|
||||
/* Actual important part */
|
||||
exit(EXIT_SUCCESS);
|
||||
}
|
||||
|
||||
struct cell* prim_list(struct cell* args) {return args;}
|
||||
struct cell* prim_cons(struct cell* args) { return make_cons(args->car, args->cdr->car); }
|
||||
struct cell* prim_car(struct cell* args) { return args->car->car; }
|
||||
struct cell* prim_cdr(struct cell* args) { return args->car->cdr; }
|
||||
|
||||
void spinup(struct cell* sym, struct cell* prim)
|
||||
{
|
||||
all_symbols = make_cons(sym, all_symbols);
|
||||
top_env = extend(top_env, sym, prim);
|
||||
}
|
||||
|
||||
/*** Initialization ***/
|
||||
struct cell* intern(char *name);
|
||||
struct cell* make_prim(void* fun);
|
||||
struct cell* make_sym(char* name);
|
||||
void init_sl3()
|
||||
{
|
||||
/* Special symbols */
|
||||
nil = make_sym("nil");
|
||||
tee = make_sym("#t");
|
||||
quote = make_sym("quote");
|
||||
s_if = make_sym("if");
|
||||
s_cond = make_sym("cond");
|
||||
s_lambda = make_sym("lambda");
|
||||
s_define = make_sym("define");
|
||||
s_setb = make_sym("set!");
|
||||
s_begin = make_sym("begin");
|
||||
s_let = make_sym("let");
|
||||
s_while = make_sym("while");
|
||||
|
||||
/* Globals of interest */
|
||||
all_symbols = make_cons(nil, nil);
|
||||
top_env = extend(nil, nil, nil);
|
||||
|
||||
/* Add Eval Specials */
|
||||
spinup(tee, tee);
|
||||
spinup(quote, quote);
|
||||
spinup(s_if, s_if);
|
||||
spinup(s_cond, s_cond);
|
||||
spinup(s_lambda, s_lambda);
|
||||
spinup(s_define, s_define);
|
||||
spinup(s_setb, s_setb);
|
||||
spinup(s_begin, s_begin);
|
||||
spinup(s_let, s_let);
|
||||
spinup(s_while, s_while);
|
||||
|
||||
/* Add Primitive Specials */
|
||||
spinup(make_sym("apply"), make_prim(prim_apply));
|
||||
spinup(make_sym("null?"), make_prim(nullp));
|
||||
spinup(make_sym("+"), make_prim(prim_sum));
|
||||
spinup(make_sym("-"), make_prim(prim_sub));
|
||||
spinup(make_sym("*"), make_prim(prim_prod));
|
||||
spinup(make_sym("/"), make_prim(prim_div));
|
||||
spinup(make_sym("mod"), make_prim(prim_mod));
|
||||
spinup(make_sym("and"), make_prim(prim_and));
|
||||
spinup(make_sym("or"), make_prim(prim_or));
|
||||
spinup(make_sym("not"), make_prim(prim_not));
|
||||
spinup(make_sym(">"), make_prim(prim_numgt));
|
||||
spinup(make_sym(">="), make_prim(prim_numge));
|
||||
spinup(make_sym("="), make_prim(prim_numeq));
|
||||
spinup(make_sym("<="), make_prim(prim_numle));
|
||||
spinup(make_sym("<"), make_prim(prim_numlt));
|
||||
spinup(make_sym("display"), make_prim(prim_display));
|
||||
spinup(make_sym("write"), make_prim(prim_write));
|
||||
spinup(make_sym("free_mem"), make_prim(prim_freecell));
|
||||
spinup(make_sym("get-type"), make_prim(prim_get_type));
|
||||
spinup(make_sym("set-type!"), make_prim(prim_set_type));
|
||||
spinup(make_sym("list?"), make_prim(prim_listp));
|
||||
spinup(make_sym("list"), make_prim(prim_list));
|
||||
spinup(make_sym("list->string"), make_prim(prim_list_to_string));
|
||||
spinup(make_sym("string->list"), make_prim(prim_string_to_list));
|
||||
spinup(make_sym("string=?"), make_prim(prim_stringeq));
|
||||
spinup(make_sym("cons"), make_prim(prim_cons));
|
||||
spinup(make_sym("car"), make_prim(prim_car));
|
||||
spinup(make_sym("cdr"), make_prim(prim_cdr));
|
||||
spinup(make_sym("echo"), make_prim(prim_echo));
|
||||
spinup(make_sym("read-byte"), make_prim(prim_read_byte));
|
||||
spinup(make_sym("HALT"), make_prim(prim_halt));
|
||||
}
|
||||
|
|
@ -0,0 +1,77 @@
|
|||
/* Copyright (C) 2016 Jeremiah Orians
|
||||
* This file is part of stage0.
|
||||
*
|
||||
* stage0 is free software: you can redistribute it and/or modify
|
||||
* it under the terms of the GNU General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or
|
||||
* (at your option) any later version.
|
||||
*
|
||||
* stage0 is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with stage0. If not, see <http://www.gnu.org/licenses/>.
|
||||
*/
|
||||
|
||||
#include "lisp.h"
|
||||
|
||||
void writeobj(FILE *output_file, struct cell* op)
|
||||
{
|
||||
if(!echo) return;
|
||||
|
||||
if(INT == op->type)
|
||||
{
|
||||
file_print(numerate_number(op->value), output_file);
|
||||
}
|
||||
else if(CONS == op->type)
|
||||
{
|
||||
fputc('(', output_file);
|
||||
do
|
||||
{
|
||||
writeobj(output_file, op->car);
|
||||
if(nil == op->cdr)
|
||||
{
|
||||
fputc(')', output_file);
|
||||
break;
|
||||
}
|
||||
op = op->cdr;
|
||||
if(op->type != CONS)
|
||||
{
|
||||
file_print(" . ", output_file);
|
||||
writeobj(output_file, op);
|
||||
fputc(')', output_file);
|
||||
break;
|
||||
}
|
||||
fputc(' ', output_file);
|
||||
} while(TRUE);
|
||||
}
|
||||
else if(SYM == op->type)
|
||||
{
|
||||
file_print(op->string, output_file);
|
||||
}
|
||||
else if(PRIMOP == op->type)
|
||||
{
|
||||
file_print("#<PRIMOP>", output_file);
|
||||
}
|
||||
else if(PROC == op->type)
|
||||
{
|
||||
file_print("#<PROC>", output_file);
|
||||
}
|
||||
else if(CHAR == op->type)
|
||||
{
|
||||
fputc(op->value, output_file);
|
||||
}
|
||||
else if(STRING == op->type)
|
||||
{
|
||||
file_print(op->string, output_file);
|
||||
}
|
||||
else
|
||||
{
|
||||
file_print("Type ", stderr);
|
||||
file_print(numerate_number(op->type), stderr);
|
||||
file_print(" is unknown\nPrint aborting hard\n", stderr);
|
||||
exit(EXIT_FAILURE);
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,290 @@
|
|||
/* Copyright (C) 2016 Jeremiah Orians
|
||||
* This file is part of stage0.
|
||||
*
|
||||
* stage0 is free software: you can redistribute it and/or modify
|
||||
* it under the terms of the GNU General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or
|
||||
* (at your option) any later version.
|
||||
*
|
||||
* stage0 is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with stage0. If not, see <http://www.gnu.org/licenses/>.
|
||||
*/
|
||||
|
||||
#include "lisp.h"
|
||||
#include <stdint.h>
|
||||
#include <string.h>
|
||||
|
||||
FILE* source_file;
|
||||
int Reached_EOF;
|
||||
|
||||
struct cell* token_stack;
|
||||
struct cell* make_sym(char* name);
|
||||
struct cell* intern(char *name);
|
||||
struct cell* findsym(char *name);
|
||||
|
||||
/****************************************************************
|
||||
* "Convert a string into a list of tokens." *
|
||||
****************************************************************/
|
||||
struct cell* tokenize(struct cell* head, char* fullstring, int size)
|
||||
{
|
||||
int i = 0;
|
||||
int done = FALSE;
|
||||
if((0 >= size) || (0 == fullstring[0]))
|
||||
{
|
||||
return head;
|
||||
}
|
||||
|
||||
char *store = calloc(MAX_STRING + 1, sizeof(char));
|
||||
|
||||
do
|
||||
{
|
||||
int c = fullstring[i];
|
||||
if((i > size) || (MAX_STRING <= i))
|
||||
{
|
||||
done = TRUE;
|
||||
}
|
||||
else if(34 == c)
|
||||
{
|
||||
store[i] = c;
|
||||
i = i + 1;
|
||||
while(34 != fullstring[i])
|
||||
{
|
||||
store[i] = fullstring[i];
|
||||
i = i + 1;
|
||||
}
|
||||
i = i + 1;
|
||||
done = TRUE;
|
||||
}
|
||||
else
|
||||
{
|
||||
if((' ' == c) || ('\t' == c) || ('\n' == c) | ('\r' == c))
|
||||
{
|
||||
i = i + 1;
|
||||
done = TRUE;
|
||||
}
|
||||
else
|
||||
{
|
||||
store[i] = c;
|
||||
i = i + 1;
|
||||
}
|
||||
}
|
||||
} while(!done);
|
||||
|
||||
if(i > 1)
|
||||
{
|
||||
struct cell* temp = make_sym(store);
|
||||
temp->cdr = head;
|
||||
head = temp;
|
||||
}
|
||||
else
|
||||
{
|
||||
free(store);
|
||||
}
|
||||
head = tokenize(head, (fullstring+i), (size - i));
|
||||
return head;
|
||||
}
|
||||
|
||||
|
||||
int is_integer(char* a)
|
||||
{
|
||||
if(('0' <= a[0]) && ('9' >= a[0]))
|
||||
{
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
if('-' == a[0])
|
||||
{
|
||||
if(('0' <= a[1]) && ('9' >= a[1]))
|
||||
{
|
||||
return TRUE;
|
||||
}
|
||||
}
|
||||
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
|
||||
/********************************************************************
|
||||
* Numbers become numbers *
|
||||
* Strings become strings *
|
||||
* Functions become functions *
|
||||
* quoted things become quoted *
|
||||
* Everything is treated like a symbol *
|
||||
********************************************************************/
|
||||
struct cell* atom(struct cell* a)
|
||||
{
|
||||
/* Check for quotes */
|
||||
if('\'' == a->string[0])
|
||||
{
|
||||
a->string = a->string + 1;
|
||||
return make_cons(quote, make_cons(a, nil));
|
||||
}
|
||||
|
||||
/* Check for strings */
|
||||
if(34 == a->string[0])
|
||||
{
|
||||
a->type = STRING;
|
||||
a->string = a->string + 1;
|
||||
return a;
|
||||
}
|
||||
|
||||
/* Check for integer */
|
||||
if(is_integer(a->string))
|
||||
{
|
||||
a->type = INT;
|
||||
a->value = numerate_string(a->string);
|
||||
return a;
|
||||
}
|
||||
|
||||
/* Check for functions */
|
||||
struct cell* op = findsym(a->string);
|
||||
if(nil != op)
|
||||
{
|
||||
return op->car;
|
||||
}
|
||||
|
||||
/* Assume new symbol */
|
||||
all_symbols = make_cons(a, all_symbols);
|
||||
return a;
|
||||
}
|
||||
|
||||
/****************************************************************
|
||||
* "Read an expression from a sequence of tokens." *
|
||||
****************************************************************/
|
||||
struct cell* readlist();
|
||||
struct cell* readobj()
|
||||
{
|
||||
struct cell* head = token_stack;
|
||||
token_stack = head->cdr;
|
||||
head->cdr = NULL;
|
||||
if (match("(", head->string))
|
||||
{
|
||||
return readlist();
|
||||
}
|
||||
|
||||
return atom(head);
|
||||
}
|
||||
|
||||
struct cell* readlist()
|
||||
{
|
||||
struct cell* head = token_stack;
|
||||
if (match(")", head->string))
|
||||
{
|
||||
token_stack = head->cdr;
|
||||
return nil;
|
||||
}
|
||||
|
||||
struct cell* tmp = readobj();
|
||||
/* token_stack = head->cdr; */
|
||||
return make_cons(tmp,readlist());
|
||||
}
|
||||
|
||||
/****************************************************
|
||||
* Put list of tokens in correct order *
|
||||
****************************************************/
|
||||
struct cell* reverse_list(struct cell* head)
|
||||
{
|
||||
struct cell* root = NULL;
|
||||
while(NULL != head)
|
||||
{
|
||||
struct cell* next = head->cdr;
|
||||
head->cdr = root;
|
||||
root = head;
|
||||
head = next;
|
||||
}
|
||||
return root;
|
||||
}
|
||||
|
||||
/****************************************************
|
||||
* "Read a Scheme expression from a string." *
|
||||
****************************************************/
|
||||
struct cell* parse(char* program, int size)
|
||||
{
|
||||
token_stack = tokenize(NULL, program, size);
|
||||
if(NULL == token_stack)
|
||||
{
|
||||
return nil;
|
||||
}
|
||||
token_stack = reverse_list(token_stack);
|
||||
return readobj();
|
||||
}
|
||||
|
||||
/****************************************************
|
||||
* Do the heavy lifting of reading an s-expreesion *
|
||||
****************************************************/
|
||||
unsigned Readline(FILE* source_file, char* temp)
|
||||
{
|
||||
int c;
|
||||
unsigned i;
|
||||
unsigned depth = 0;
|
||||
|
||||
for(i = 0; i < MAX_STRING; i = i + 1)
|
||||
{
|
||||
restart_comment:
|
||||
c = fgetc(source_file);
|
||||
if((-1 == c) || (4 == c))
|
||||
{
|
||||
return i;
|
||||
}
|
||||
else if(';' == c)
|
||||
{
|
||||
/* drop everything until we hit newline */
|
||||
while('\n' != c)
|
||||
{
|
||||
c = fgetc(source_file);
|
||||
}
|
||||
goto restart_comment;
|
||||
}
|
||||
else if('"' == c)
|
||||
{ /* Deal with strings */
|
||||
temp[i] = c;
|
||||
i = i + 1;
|
||||
c = fgetc(source_file);
|
||||
while('"' != c)
|
||||
{
|
||||
temp[i] = c;
|
||||
i = i + 1;
|
||||
c = fgetc(source_file);
|
||||
}
|
||||
temp[i] = c;
|
||||
}
|
||||
else if((0 == depth) && (('\n' == c) || ('\r' == c) || (' ' == c) || ('\t' == c)))
|
||||
{
|
||||
goto Line_complete;
|
||||
}
|
||||
else if(('(' == c) || (')' == c))
|
||||
{
|
||||
if('(' == c)
|
||||
{
|
||||
depth = depth + 1;
|
||||
}
|
||||
|
||||
if(')' == c)
|
||||
{
|
||||
depth = depth - 1;
|
||||
}
|
||||
|
||||
temp[i] = ' ';
|
||||
temp[i+1] = c;
|
||||
temp[i+2] = ' ';
|
||||
i = i + 2;
|
||||
}
|
||||
else
|
||||
{
|
||||
temp[i] = c;
|
||||
}
|
||||
}
|
||||
|
||||
Line_complete:
|
||||
if(1 > i)
|
||||
{
|
||||
return Readline(source_file, temp);
|
||||
}
|
||||
|
||||
return i;
|
||||
}
|
||||
Loading…
Reference in New Issue