mirror of
https://github.com/kanaka/mal.git
synced 2024-10-05 18:08:55 +03:00
renamed to c.2 and rebased onto latest master
This commit is contained in:
parent
9d0331494e
commit
fe6c42e303
4
.gitignore
vendored
4
.gitignore
vendored
@ -16,7 +16,9 @@ package-lock.json
|
||||
*/experiments
|
||||
node_modules
|
||||
*/notes
|
||||
|
||||
GPATH
|
||||
GTAGS
|
||||
GRTAGS
|
||||
logs
|
||||
old
|
||||
tmp/
|
||||
|
@ -34,7 +34,7 @@ wasm_MODE = wasmtime
|
||||
# Implementation specific settings
|
||||
#
|
||||
|
||||
IMPLS = ada ada.2 awk bash basic bbc-basic c chuck clojure coffee common-lisp cpp crystal cs d dart \
|
||||
IMPLS = ada ada.2 awk bash basic bbc-basic c c.2 chuck clojure coffee common-lisp cpp crystal cs d dart \
|
||||
elisp elixir elm erlang es6 factor fantom fennel forth fsharp go groovy gnu-smalltalk \
|
||||
guile haskell haxe hy io janet java js jq julia kotlin livescript logo lua make mal \
|
||||
matlab miniMAL nasm nim objc objpascal ocaml perl perl6 php picolisp pike plpgsql \
|
||||
@ -110,6 +110,7 @@ bash_STEP_TO_PROG = impls/bash/$($(1)).sh
|
||||
basic_STEP_TO_PROG = $(basic_STEP_TO_PROG_$(basic_MODE))
|
||||
bbc-basic_STEP_TO_PROG = impls/bbc-basic/$($(1)).bas
|
||||
c_STEP_TO_PROG = impls/c/$($(1))
|
||||
c.2_STEP_TO_PROG = impls/c.2/$($(1))
|
||||
chuck_STEP_TO_PROG = impls/chuck/$($(1)).ck
|
||||
clojure_STEP_TO_PROG = $(clojure_STEP_TO_PROG_$(clojure_MODE))
|
||||
coffee_STEP_TO_PROG = impls/coffee/$($(1)).coffee
|
||||
@ -192,4 +193,3 @@ wren_STEP_TO_PROG = impls/wren/$($(1)).wren
|
||||
yorick_STEP_TO_PROG = impls/yorick/$($(1)).i
|
||||
xslt_STEP_TO_PROG = impls/xslt/$($(1))
|
||||
zig_STEP_TO_PROG = impls/zig/$($(1))
|
||||
|
||||
|
28
impls/c.2/Dockerfile
Normal file
28
impls/c.2/Dockerfile
Normal file
@ -0,0 +1,28 @@
|
||||
FROM ubuntu:bionic
|
||||
MAINTAINER Duncan Watts <fungiblecog@gmail.com>
|
||||
|
||||
##########################################################
|
||||
# General requirements for testing or common across many
|
||||
# implementations
|
||||
##########################################################
|
||||
|
||||
RUN apt-get -y update
|
||||
|
||||
# Required for running tests
|
||||
RUN apt-get -y install make python
|
||||
|
||||
# Some typical implementation and test requirements
|
||||
#RUN apt-get -y install curl
|
||||
|
||||
RUN mkdir -p /mal
|
||||
WORKDIR /mal
|
||||
|
||||
##########################################################
|
||||
# Specific implementation requirements
|
||||
##########################################################
|
||||
|
||||
# Install gcc
|
||||
RUN apt-get -y install gcc
|
||||
|
||||
# Libraries needed for the C impl
|
||||
RUN apt-get -y install libffi-dev libgc-dev libedit-dev
|
93
impls/c.2/Makefile
Normal file
93
impls/c.2/Makefile
Normal file
@ -0,0 +1,93 @@
|
||||
CC = gcc
|
||||
|
||||
CFLAGS = -std=c99 -g -Wall
|
||||
|
||||
LIBS = -ledit -lgc
|
||||
FFI_LIBS = -ldl -lffi
|
||||
|
||||
SRC = reader.c printer.c types.c env.c core.c
|
||||
HEADERS = reader.h printer.h types.h env.h core.h
|
||||
|
||||
LIB_DIR = ./libs
|
||||
LIB_LIST_H = $(LIB_DIR)/linked_list/linked_list.h
|
||||
LIB_LIST_SRC = $(LIB_DIR)/linked_list/linked_list.c
|
||||
|
||||
LIB_MAP_H = $(LIB_DIR)/hashmap/hashmap.h
|
||||
LIB_MAP_SRC = $(LIB_DIR)/hashmap/hashmap.c
|
||||
|
||||
LIBS_H = $(LIB_LIST_H) $(LIB_MAP_H)
|
||||
LIBS_SRC = $(LIB_LIST_SRC) $(LIB_MAP_SRC)
|
||||
|
||||
S0_SRC = step0_repl.c
|
||||
S1_SRC = step1_read_print.c reader.c types.c printer.c $(LIB_LIST_SRC)
|
||||
S2_SRC = step2_eval.c reader.c types.c printer.c $(LIBS_SRC)
|
||||
S3_SRC = step3_env.c reader.c types.c printer.c env.c $(LIBS_SRC)
|
||||
S4_SRC = step4_if_fn_do.c $(SRC) $(LIBS_SRC)
|
||||
S5_SRC = step5_tco.c $(SRC) $(LIBS_SRC)
|
||||
S6_SRC = step6_file.c $(SRC) $(LIBS_SRC)
|
||||
S7_SRC = step7_quote.c $(SRC) $(LIBS_SRC)
|
||||
S8_SRC = step8_macros.c $(SRC) $(LIBS_SRC)
|
||||
S9_SRC = step9_try.c $(SRC) $(LIBS_SRC)
|
||||
SA_SRC = stepA_mal.c $(SRC) $(LIBS_SRC)
|
||||
|
||||
S0_HEADERS =
|
||||
S1_HEADERS = reader.h types.h printer.h $(LIB_LIST_H)
|
||||
S2_HEADERS = reader.h types.h printer.h $(LIBS_H)
|
||||
S3_HEADERS = reader.h types.h printer.h env.h $(LIBS_H)
|
||||
S4_HEADERS = $(HEADERS) $(LIBS_H)
|
||||
S5_HEADERS = $(HEADERS) $(LIBS_H)
|
||||
S6_HEADERS = $(HEADERS) $(LIBS_H)
|
||||
S7_HEADERS = $(HEADERS) $(LIBS_H)
|
||||
S8_HEADERS = $(HEADERS) $(LIBS_H)
|
||||
S9_HEADERS = $(HEADERS) $(LIBS_H)
|
||||
SA_HEADERS = $(HEADERS) $(LIBS_H)
|
||||
|
||||
S0 = step0_repl
|
||||
S1 = step1_read_print
|
||||
S2 = step2_eval
|
||||
S3 = step3_env
|
||||
S4 = step4_if_fn_do
|
||||
S5 = step5_tco
|
||||
S6 = step6_file
|
||||
S7 = step7_quote
|
||||
S8 = step8_macros
|
||||
S9 = step9_try
|
||||
SA = stepA_mal
|
||||
|
||||
.PHONY all: $(S0) $(S1) $(S2) $(S3) $(S4) $(S5) $(S6) $(S7) $(S8) $(S9) $(SA)
|
||||
|
||||
$(S0): $(S0_SRC) $(S0_HEADERS)
|
||||
$(CC) $(CFLAGS) $(S0_SRC) $(LIBS) -o $(S0)
|
||||
|
||||
$(S1): $(S1_SRC) $(S1_HEADERS)
|
||||
$(CC) $(CFLAGS) $(S1_SRC) $(LIBS) -o $(S1)
|
||||
|
||||
$(S2): $(S2_SRC) $(S2_HEADERS)
|
||||
$(CC) $(CFLAGS) $(S2_SRC) $(LIBS) -o $(S2)
|
||||
|
||||
$(S3): $(S3_SRC) $(S3_HEADERS)
|
||||
$(CC) $(CFLAGS) $(S3_SRC) $(LIBS) -o $(S3)
|
||||
|
||||
$(S4): $(S4_SRC) $(S4_HEADERS)
|
||||
$(CC) $(CFLAGS) $(S4_SRC) $(LIBS) -o $(S4)
|
||||
|
||||
$(S5): $(S5_SRC) $(S5_HEADERS)
|
||||
$(CC) $(CFLAGS) $(S5_SRC) $(LIBS) -o $(S5)
|
||||
|
||||
$(S6): $(S6_SRC) $(S6_HEADERS)
|
||||
$(CC) $(CFLAGS) $(S6_SRC) $(LIBS) -o $(S6)
|
||||
|
||||
$(S7): $(S7_SRC) $(S7_HEADERS)
|
||||
$(CC) $(CFLAGS) $(S7_SRC) $(LIBS) -o $(S7)
|
||||
|
||||
$(S8): $(S8_SRC) $(S8_HEADERS)
|
||||
$(CC) $(CFLAGS) $(S8_SRC) $(LIBS) -o $(S8)
|
||||
|
||||
$(S9): $(S9_SRC) $(S9_HEADERS)
|
||||
$(CC) $(CFLAGS) $(S9_SRC) $(LIBS) -o $(S9)
|
||||
|
||||
$(SA): $(SA_SRC) $(SA_HEADERS)
|
||||
$(CC) $(CFLAGS) $(SA_SRC) $(LIBS) $(FFI_LIBS) -DWITH_FFI -o $(SA)
|
||||
|
||||
.PHONY clean:
|
||||
rm -f $(S0) $(S1) $(S2) $(S3) $(S4) $(S5) $(S6) $(S7) $(S8) $(S9) $(SA)
|
1996
impls/c.2/core.c
Normal file
1996
impls/c.2/core.c
Normal file
File diff suppressed because it is too large
Load Diff
22
impls/c.2/core.h
Normal file
22
impls/c.2/core.h
Normal file
@ -0,0 +1,22 @@
|
||||
#ifndef _MAL_CORE_H
|
||||
#define _MAL_CORE_H
|
||||
|
||||
#include "libs/hashmap/hashmap.h"
|
||||
#include "types.h"
|
||||
|
||||
typedef struct ns_s ns;
|
||||
|
||||
struct ns_s {
|
||||
|
||||
hashmap mappings;
|
||||
|
||||
};
|
||||
|
||||
ns* ns_make_core();
|
||||
MalType* as_str(list args, int readably, char* separator);
|
||||
MalType* print(list args, int readably, char* separator);
|
||||
char* get_fn(gptr data);
|
||||
MalType* equal_lists(MalType* lst1, MalType* lst2);
|
||||
MalType* equal_hashmaps(MalType* map1, MalType* map2);
|
||||
|
||||
#endif
|
67
impls/c.2/env.c
Normal file
67
impls/c.2/env.c
Normal file
@ -0,0 +1,67 @@
|
||||
#include <stdio.h>
|
||||
#include <gc.h>
|
||||
|
||||
#include "libs/hashmap/hashmap.h"
|
||||
#include "types.h"
|
||||
#include "env.h"
|
||||
#include "reader.h"
|
||||
|
||||
/* Note: caller must make sure enough exprs to match symbols */
|
||||
Env* env_make(Env* outer, list symbol_list, list exprs_list, MalType* more_symbol) {
|
||||
|
||||
Env* env = GC_MALLOC(sizeof(*env));
|
||||
env->outer = outer;
|
||||
env->data = NULL;
|
||||
|
||||
while (symbol_list) {
|
||||
|
||||
env = env_set(env, symbol_list->data, exprs_list->data);
|
||||
|
||||
symbol_list = symbol_list->next;
|
||||
exprs_list = exprs_list->next;
|
||||
}
|
||||
|
||||
/* set the 'more' symbol if there is one */
|
||||
if (more_symbol) {
|
||||
env = env_set(env, more_symbol, make_list(exprs_list));
|
||||
}
|
||||
return env;
|
||||
}
|
||||
|
||||
Env* env_set(Env* current, MalType* symbol, MalType* value) {
|
||||
|
||||
current->data = hashmap_put(current->data, symbol->value.mal_symbol, value);
|
||||
return current;
|
||||
}
|
||||
|
||||
Env* env_find(Env* current, MalType* symbol) {
|
||||
|
||||
MalType* val = hashmap_get(current->data, symbol->value.mal_symbol);
|
||||
|
||||
if (val) {
|
||||
return current;
|
||||
}
|
||||
else if (current->outer) {
|
||||
return env_find(current->outer, symbol);
|
||||
}
|
||||
else {
|
||||
return NULL; /* not found */
|
||||
}
|
||||
}
|
||||
|
||||
MalType* env_get(Env* current, MalType* symbol) {
|
||||
|
||||
Env* env = env_find(current, symbol);
|
||||
|
||||
if (env) {
|
||||
return hashmap_get(env->data, symbol->value.mal_symbol);
|
||||
}
|
||||
else {
|
||||
return make_error_fmt("'%s' not found", symbol->value.mal_symbol);
|
||||
}
|
||||
}
|
||||
|
||||
Env* env_set_C_fn(Env* current, char* symbol_name, MalType*(*fn)(list)) {
|
||||
|
||||
return env_set(current, make_symbol(symbol_name), make_function(fn));
|
||||
}
|
23
impls/c.2/env.h
Normal file
23
impls/c.2/env.h
Normal file
@ -0,0 +1,23 @@
|
||||
#ifndef _MAL_ENV_H
|
||||
#define _MAL_ENV_H
|
||||
|
||||
#include "libs/linked_list/linked_list.h"
|
||||
#include "libs/hashmap/hashmap.h"
|
||||
#include "types.h"
|
||||
|
||||
typedef struct Env_s Env;
|
||||
|
||||
struct Env_s {
|
||||
|
||||
struct Env_s* outer;
|
||||
hashmap data;
|
||||
|
||||
};
|
||||
|
||||
Env* env_make(Env* outer, list binds, list exprs, MalType* variadic_symbol);
|
||||
Env* env_set(Env* current, MalType* symbol, MalType* value);
|
||||
Env* env_set_C_fn(Env* current, char* symbol_name, MalType*(*fn)(list));
|
||||
MalType* env_get(Env* current, MalType* symbol);
|
||||
Env* env_find(Env* current, MalType* symbol);
|
||||
|
||||
#endif
|
93
impls/c.2/libs/hashmap/hashmap.c
Normal file
93
impls/c.2/libs/hashmap/hashmap.c
Normal file
@ -0,0 +1,93 @@
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
#include <gc.h>
|
||||
|
||||
#include "hashmap.h"
|
||||
|
||||
hashmap hashmap_make(char* keystring, gptr data_ptr) {
|
||||
|
||||
list map = list_make(data_ptr);
|
||||
map = list_push(map, keystring);
|
||||
|
||||
return map;
|
||||
}
|
||||
|
||||
hashmap hashmap_put(hashmap map, char* keystring, gptr data_ptr) {
|
||||
|
||||
map = list_push(map, data_ptr);
|
||||
map = list_push(map, keystring);
|
||||
|
||||
return map;
|
||||
}
|
||||
|
||||
gptr hashmap_get(hashmap map, char* keystring) {
|
||||
|
||||
/* handle empty case */
|
||||
if (!map) {
|
||||
return NULL;
|
||||
}
|
||||
|
||||
list lst = map;
|
||||
|
||||
while(lst) {
|
||||
|
||||
if (strcmp(keystring, (char*)lst->data) == 0) {
|
||||
return (lst->next)->data; /* return next item in list which is the value */
|
||||
}
|
||||
else {
|
||||
lst = (lst->next)->next; /* skip the next item in the list to get to the next key */
|
||||
}
|
||||
}
|
||||
return NULL; /* not found */
|
||||
}
|
||||
|
||||
|
||||
gptr hashmap_getf(hashmap map, char* keystring, char*(*fn)(gptr)) {
|
||||
|
||||
/* handle empty case */
|
||||
if (!map) {
|
||||
return NULL;
|
||||
}
|
||||
|
||||
list lst = map;
|
||||
|
||||
while(lst) {
|
||||
|
||||
/* apply fn to the data to get a string */
|
||||
char* item = fn(lst->data);
|
||||
|
||||
if (strcmp(keystring, item) == 0) {
|
||||
return (lst->next)->data; /* return next item in list which is the value */
|
||||
}
|
||||
else {
|
||||
lst = (lst->next)->next; /* skip the next item in the list to get to the next key */
|
||||
}
|
||||
}
|
||||
return NULL; /* not found */
|
||||
}
|
||||
|
||||
hashmap hashmap_updatef(hashmap map, char* keystring, gptr value, char*(*fn)(gptr)) {
|
||||
|
||||
/* handle empty case */
|
||||
if (!map) {
|
||||
return NULL;
|
||||
}
|
||||
|
||||
list lst = map;
|
||||
|
||||
while(lst) {
|
||||
|
||||
/* apply fn to the data to get a string */
|
||||
char* item = fn(lst->data);
|
||||
|
||||
if (strcmp(keystring, item) == 0) {
|
||||
(lst->next)->data = value; /* update the next item in list which is the value */
|
||||
return map; /* update made */
|
||||
}
|
||||
else {
|
||||
lst = (lst->next)->next; /* skip the next item in the list to get to the next key */
|
||||
}
|
||||
}
|
||||
|
||||
return NULL; /* no update */
|
||||
}
|
15
impls/c.2/libs/hashmap/hashmap.h
Normal file
15
impls/c.2/libs/hashmap/hashmap.h
Normal file
@ -0,0 +1,15 @@
|
||||
#ifndef _MAL_HASHMAP_H
|
||||
#define _MAL_HASHMAP_H
|
||||
|
||||
#include "../linked_list/linked_list.h"
|
||||
|
||||
/* a hashmap is just a list with alternating key/value pairs */
|
||||
typedef list hashmap;
|
||||
|
||||
hashmap hashmap_make(char* keystring, gptr data_ptr);
|
||||
hashmap hashmap_put(hashmap map, char* keystring, gptr data_ptr);
|
||||
gptr hashmap_get(hashmap map, char* keystring);
|
||||
gptr hashmap_getf(hashmap map, char* keystring, char*(*fn)(gptr));
|
||||
hashmap hashmap_updatef(hashmap map, char* keystring, gptr value, char*(*fn)(gptr));
|
||||
|
||||
#endif
|
171
impls/c.2/libs/linked_list/linked_list.c
Normal file
171
impls/c.2/libs/linked_list/linked_list.c
Normal file
@ -0,0 +1,171 @@
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
#include <gc.h>
|
||||
#include "linked_list.h"
|
||||
|
||||
list list_make(gptr data_ptr) {
|
||||
|
||||
return list_push(NULL, data_ptr);
|
||||
}
|
||||
|
||||
list list_push(list lst, gptr data_ptr) {
|
||||
|
||||
pair* new_head = GC_malloc(sizeof(pair));
|
||||
new_head->data = data_ptr;
|
||||
new_head->next = lst;
|
||||
|
||||
return new_head;
|
||||
}
|
||||
|
||||
gptr list_peek(list lst) {
|
||||
|
||||
return (lst ? lst->data : NULL);
|
||||
}
|
||||
|
||||
list list_pop(list lst) {
|
||||
return (lst ? lst->next : NULL);
|
||||
}
|
||||
|
||||
long list_count(list lst) {
|
||||
|
||||
/* handle empty case */
|
||||
if (!lst) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
long counter = 1;
|
||||
|
||||
while(lst->next) {
|
||||
|
||||
counter++;
|
||||
lst = lst->next;
|
||||
}
|
||||
|
||||
return counter;
|
||||
}
|
||||
|
||||
list list_reverse(list lst) {
|
||||
|
||||
/* list is not empty and has more than one element */
|
||||
if (lst && lst->next) {
|
||||
|
||||
pair *prev = NULL, *next = NULL, *current = lst;
|
||||
|
||||
while (current) {
|
||||
|
||||
/* stash current value of next pointer --> */
|
||||
next = current->next;
|
||||
|
||||
/* reverse the next pointer on current pair <-- */
|
||||
current->next = prev;
|
||||
|
||||
/* move on to next pair and repeat --> */
|
||||
prev = current;
|
||||
current = next;
|
||||
|
||||
}
|
||||
|
||||
lst = prev; /* head of list is in prev when current = NULL */
|
||||
}
|
||||
|
||||
return lst;
|
||||
}
|
||||
|
||||
list list_concatenate(list lst1, list lst2) {
|
||||
|
||||
list new_lst = NULL;
|
||||
list iterator = NULL;
|
||||
|
||||
while (lst2) {
|
||||
|
||||
gptr val = lst2->data;
|
||||
new_lst = list_push(new_lst, val);
|
||||
lst2 = lst2->next;
|
||||
}
|
||||
new_lst = list_reverse(new_lst);
|
||||
|
||||
lst1 = list_reverse(lst1);
|
||||
|
||||
iterator = lst1;
|
||||
while (iterator) {
|
||||
|
||||
gptr val = iterator->data;
|
||||
new_lst = list_push(new_lst, val);
|
||||
iterator = iterator->next;
|
||||
}
|
||||
|
||||
lst1 = list_reverse(lst1);
|
||||
return new_lst;
|
||||
}
|
||||
|
||||
gptr list_nth(list lst, int n) {
|
||||
|
||||
int idx = 0;
|
||||
while (lst) {
|
||||
|
||||
if (n == idx) {
|
||||
return lst->data;
|
||||
}
|
||||
idx++;
|
||||
lst = lst->next;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
gptr list_first(list lst) {
|
||||
|
||||
if (lst) {
|
||||
return lst->data;
|
||||
}
|
||||
else {
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
|
||||
list list_rest(list lst) {
|
||||
|
||||
if (lst) {
|
||||
return lst->next;
|
||||
}
|
||||
else {
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
|
||||
list list_copy(list lst) {
|
||||
|
||||
if(!lst) {
|
||||
return NULL;
|
||||
}
|
||||
|
||||
list new_lst = NULL;
|
||||
while(lst) {
|
||||
|
||||
new_lst = list_push(new_lst, lst->data);
|
||||
lst = lst->next;
|
||||
}
|
||||
return new_lst;
|
||||
}
|
||||
|
||||
long list_findf(list lst, char* keystring, char*(*fn)(gptr)) {
|
||||
|
||||
/* handle empty case */
|
||||
if (!lst) {
|
||||
return -1;
|
||||
}
|
||||
|
||||
list current = lst;
|
||||
while(current) {
|
||||
|
||||
/* apply fn to the data to get a string */
|
||||
char* item = fn(current->data);
|
||||
|
||||
if (strcmp(keystring, item) == 0) {
|
||||
return (current - lst); /* return the index of the first match */
|
||||
}
|
||||
else {
|
||||
current = current->next; /* skip the next item in the list to*/
|
||||
}
|
||||
}
|
||||
return -1; /* not found */
|
||||
}
|
32
impls/c.2/libs/linked_list/linked_list.h
Normal file
32
impls/c.2/libs/linked_list/linked_list.h
Normal file
@ -0,0 +1,32 @@
|
||||
#ifndef _MAL_LINKED_LIST_H
|
||||
#define _MAL_LINKED_LIST_H
|
||||
|
||||
/* simplify references to void pointers */
|
||||
typedef void* gptr;
|
||||
|
||||
/* linked list is constructed of pairs */
|
||||
typedef struct pair_s {
|
||||
|
||||
gptr data;
|
||||
struct pair_s *next;
|
||||
|
||||
} pair;
|
||||
|
||||
/* a list is just a pointer to the pair at the head of the list */
|
||||
typedef pair* list;
|
||||
|
||||
/* interface */
|
||||
list list_make(gptr data_ptr);
|
||||
list list_push(list lst, gptr data_ptr);
|
||||
gptr list_peek(list lst);
|
||||
gptr list_nth(list lst, int n);
|
||||
gptr list_first(list lst);
|
||||
list list_rest(list lst);
|
||||
list list_pop(list lst);
|
||||
list list_reverse(list lst);
|
||||
long list_count(list lst);
|
||||
list list_concatenate(list lst1, list lst2);
|
||||
list list_copy(list lst);
|
||||
long list_findf(list lst, char* keystring, char*(*fn)(gptr));
|
||||
|
||||
#endif
|
255
impls/c.2/printer.c
Normal file
255
impls/c.2/printer.c
Normal file
@ -0,0 +1,255 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <gc.h>
|
||||
|
||||
#include "printer.h"
|
||||
|
||||
#define PRINT_NIL "nil"
|
||||
#define PRINT_TRUE "true"
|
||||
#define PRINT_FALSE "false"
|
||||
|
||||
#define INTEGER_BUFFER_SIZE 16
|
||||
#define SYMBOL_BUFFER_SIZE 32
|
||||
#define FUNCTION_BUFFER_SIZE 256
|
||||
#define STRING_BUFFER_SIZE 256
|
||||
#define LIST_BUFFER_SIZE 1024
|
||||
|
||||
char* pr_str(MalType* val, int readably) {
|
||||
|
||||
if (!val) {
|
||||
return "";
|
||||
}
|
||||
|
||||
switch(val->type) {
|
||||
|
||||
case MALTYPE_SYMBOL:
|
||||
|
||||
return snprintfbuf(SYMBOL_BUFFER_SIZE, "%s", val->value.mal_symbol);
|
||||
break;
|
||||
|
||||
case MALTYPE_KEYWORD:
|
||||
|
||||
return snprintfbuf(SYMBOL_BUFFER_SIZE, ":%s", val->value.mal_keyword);
|
||||
break;
|
||||
|
||||
case MALTYPE_INTEGER:
|
||||
|
||||
return snprintfbuf(SYMBOL_BUFFER_SIZE, "%ld", val->value.mal_integer);
|
||||
break;
|
||||
|
||||
case MALTYPE_FLOAT:
|
||||
|
||||
return snprintfbuf(SYMBOL_BUFFER_SIZE, "%lf", val->value.mal_float);
|
||||
break;
|
||||
|
||||
case MALTYPE_STRING:
|
||||
|
||||
if (readably) {
|
||||
return snprintfbuf(STRING_BUFFER_SIZE, "%s", escape_string(val->value.mal_string));
|
||||
}
|
||||
else {
|
||||
return snprintfbuf(STRING_BUFFER_SIZE, "%s",val->value.mal_string);
|
||||
}
|
||||
break;
|
||||
|
||||
case MALTYPE_TRUE:
|
||||
|
||||
return PRINT_TRUE;
|
||||
break;
|
||||
|
||||
case MALTYPE_FALSE:
|
||||
|
||||
return PRINT_FALSE;
|
||||
break;
|
||||
|
||||
case MALTYPE_NIL:
|
||||
|
||||
return PRINT_NIL;
|
||||
break;
|
||||
|
||||
case MALTYPE_LIST:
|
||||
|
||||
return pr_str_list(val->value.mal_list, readably, "(", ")", " ");
|
||||
break;
|
||||
|
||||
case MALTYPE_VECTOR:
|
||||
|
||||
return pr_str_list(val->value.mal_list, readably, "[", "]", " ");
|
||||
break;
|
||||
|
||||
case MALTYPE_HASHMAP:
|
||||
|
||||
return pr_str_list(val->value.mal_list, readably, "{", "}", " ");
|
||||
break;
|
||||
|
||||
case MALTYPE_FUNCTION:
|
||||
|
||||
return snprintfbuf(FUNCTION_BUFFER_SIZE, "#<function::native@%p>", val->value.mal_function);
|
||||
break;
|
||||
|
||||
case MALTYPE_CLOSURE:
|
||||
{
|
||||
MalType* definition = (val->value.mal_closure)->definition;
|
||||
MalType* parameters = (val->value.mal_closure)->parameters;
|
||||
MalType* more_symbol = (val->value.mal_closure)->more_symbol;
|
||||
|
||||
list lst = parameters->value.mal_list;
|
||||
|
||||
if (more_symbol) {
|
||||
lst = list_reverse(lst);
|
||||
lst = list_push(lst, make_symbol(snprintfbuf(STRING_BUFFER_SIZE, "%s%s", "&", more_symbol->value.mal_symbol)));
|
||||
lst = list_reverse(lst);
|
||||
}
|
||||
|
||||
if (val->is_macro) {
|
||||
return snprintfbuf(FUNCTION_BUFFER_SIZE, "#<function::macro: (fn* %s %s))", \
|
||||
pr_str(make_list(lst), UNREADABLY), pr_str(definition, UNREADABLY));
|
||||
}
|
||||
else {
|
||||
return snprintfbuf(FUNCTION_BUFFER_SIZE, "#<function::closure: (fn* %s %s))", \
|
||||
pr_str(make_list(lst), UNREADABLY), pr_str(definition, UNREADABLY));
|
||||
}
|
||||
}
|
||||
break;
|
||||
|
||||
case MALTYPE_ATOM:
|
||||
|
||||
return snprintfbuf(STRING_BUFFER_SIZE, "(atom %s)", pr_str(val->value.mal_atom, readably));
|
||||
break;
|
||||
|
||||
case MALTYPE_ERROR:
|
||||
|
||||
return snprintfbuf(STRING_BUFFER_SIZE, "Uncaught error: %s", pr_str(val->value.mal_error, UNREADABLY));
|
||||
break;
|
||||
|
||||
default:
|
||||
/* can't happen unless a new MalType is added */
|
||||
return "Printer error: unknown type\n";
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
char* pr_str_list(list lst, int readably, char* start_delimiter, char* end_delimiter, char* separator) {
|
||||
|
||||
char* list_buffer = GC_MALLOC(sizeof(*list_buffer) * LIST_BUFFER_SIZE);
|
||||
long buffer_length = LIST_BUFFER_SIZE;
|
||||
|
||||
/* add the start delimiter */
|
||||
list_buffer = strcpy(list_buffer, start_delimiter);
|
||||
|
||||
long len = strlen(start_delimiter);
|
||||
long count = len;
|
||||
|
||||
while (lst) {
|
||||
|
||||
/* concatenate next element */
|
||||
MalType* data = lst->data;
|
||||
char* str = pr_str(data, readably);
|
||||
|
||||
len = strlen(str);
|
||||
count += len;
|
||||
|
||||
if (count >= buffer_length) {
|
||||
buffer_length += (count + 1);
|
||||
list_buffer = GC_REALLOC(list_buffer, buffer_length);
|
||||
}
|
||||
|
||||
strncat(list_buffer, str, len);
|
||||
lst = lst->next;
|
||||
|
||||
if (lst) {
|
||||
len = strlen(separator);
|
||||
count += len;
|
||||
|
||||
if (count >= buffer_length) {
|
||||
buffer_length += (count + 1);
|
||||
list_buffer = GC_REALLOC(list_buffer, buffer_length);
|
||||
}
|
||||
/* add the separator */
|
||||
strncat(list_buffer, separator, len);
|
||||
}
|
||||
}
|
||||
|
||||
if (count >= buffer_length) {
|
||||
len = strlen(end_delimiter);
|
||||
count += len;
|
||||
|
||||
buffer_length += (count + 1);
|
||||
list_buffer = GC_REALLOC(list_buffer, buffer_length);
|
||||
}
|
||||
|
||||
/* add the end delimiter */
|
||||
strncat(list_buffer, end_delimiter, len);
|
||||
|
||||
return list_buffer;
|
||||
}
|
||||
|
||||
|
||||
char* escape_string(char* str) {
|
||||
|
||||
long buffer_length = 2*(strlen(str) + 1) ; /* allocate a reasonable initial buffer size */
|
||||
char* buffer = GC_MALLOC(sizeof(*buffer) * buffer_length);
|
||||
|
||||
strcpy(buffer,"\"");
|
||||
|
||||
char* curr = str;
|
||||
while(*curr != '\0') {
|
||||
|
||||
switch (*curr) {
|
||||
|
||||
case '"':
|
||||
strcat(buffer, "\\\"");
|
||||
break;
|
||||
|
||||
case '\\':
|
||||
strcat(buffer, "\\\\");
|
||||
break;
|
||||
|
||||
case 0x0A:
|
||||
strcat(buffer, "\\n");
|
||||
break;
|
||||
|
||||
default:
|
||||
strncat(buffer, curr, 1);
|
||||
}
|
||||
curr++;
|
||||
|
||||
/* check for overflow and increase buffer size */
|
||||
if ((curr - str) >= buffer_length) {
|
||||
buffer_length *= 2;
|
||||
buffer = GC_REALLOC(buffer, sizeof(*buffer) * buffer_length);
|
||||
}
|
||||
}
|
||||
|
||||
strcat(buffer, "\"");
|
||||
|
||||
/* trim the buffer to the size of the actual escaped string */
|
||||
buffer_length = strlen(buffer);
|
||||
buffer = GC_REALLOC(buffer, sizeof(*buffer) * buffer_length + 1);
|
||||
|
||||
return buffer;
|
||||
}
|
||||
|
||||
char* snprintfbuf(long initial_size, char* fmt, ...) {
|
||||
/* this is just a wrapper for the *printf family that ensures the
|
||||
string is long enough to hold the contents */
|
||||
|
||||
va_list argptr;
|
||||
va_start(argptr, fmt);
|
||||
|
||||
char* buffer = GC_MALLOC(sizeof(*buffer) * initial_size);
|
||||
long n = vsnprintf(buffer, initial_size, fmt, argptr);
|
||||
va_end(argptr);
|
||||
|
||||
if (n > initial_size) {
|
||||
va_start(argptr, fmt);
|
||||
|
||||
buffer = GC_REALLOC(buffer, sizeof(*buffer) * n);
|
||||
vsnprintf(buffer, n, fmt, argptr);
|
||||
|
||||
va_end(argptr);
|
||||
}
|
||||
return buffer;
|
||||
}
|
15
impls/c.2/printer.h
Normal file
15
impls/c.2/printer.h
Normal file
@ -0,0 +1,15 @@
|
||||
#ifndef _PRINTER_H
|
||||
#define _PRINTER_H
|
||||
|
||||
#include <stdarg.h>
|
||||
#include "types.h"
|
||||
|
||||
#define UNREADABLY 0
|
||||
#define READABLY 1
|
||||
|
||||
char* pr_str(MalType* mal_val, int readably);
|
||||
char* pr_str_list(list lst, int readably, char* start_delimiter, char* end_delimiter, char* separator);
|
||||
char* escape_string(char* str);
|
||||
char* snprintfbuf(long initial_size, char* fmt, ...);
|
||||
|
||||
#endif
|
663
impls/c.2/reader.c
Normal file
663
impls/c.2/reader.c
Normal file
@ -0,0 +1,663 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <ctype.h>
|
||||
#include <gc.h>
|
||||
|
||||
#include "reader.h"
|
||||
|
||||
#define TOKEN_SPECIAL_CHARACTER 1
|
||||
#define TOKEN_STRING 2
|
||||
#define TOKEN_INTEGER 3
|
||||
#define TOKEN_FLOAT 4
|
||||
#define TOKEN_SYMBOL 5
|
||||
#define TOKEN_COMMENT 6
|
||||
#define TOKEN_KEYWORD 7
|
||||
#define TOKEN_TRUE 8
|
||||
#define TOKEN_FALSE 9
|
||||
#define TOKEN_NIL 10
|
||||
|
||||
#define SYMBOL_NIL "nil"
|
||||
#define SYMBOL_TRUE "true"
|
||||
#define SYMBOL_FALSE "false"
|
||||
#define SYMBOL_QUOTE "quote"
|
||||
#define SYMBOL_QUASIQUOTE "quasiquote"
|
||||
#define SYMBOL_UNQUOTE "unquote"
|
||||
#define SYMBOL_SPLICE_UNQUOTE "splice-unquote"
|
||||
#define SYMBOL_DEREF "deref"
|
||||
#define SYMBOL_WITH_META "with-meta"
|
||||
|
||||
Reader* reader_make(long token_capacity) {
|
||||
|
||||
Reader* reader = GC_MALLOC(sizeof(*reader));
|
||||
|
||||
reader->max_tokens = token_capacity;
|
||||
reader->position = 0;
|
||||
reader->token_count = 0;
|
||||
reader->token_data = GC_MALLOC(sizeof(Token*) * token_capacity);
|
||||
reader->error = NULL;
|
||||
|
||||
return reader;
|
||||
}
|
||||
|
||||
Reader* reader_append(Reader* reader, Token* token) {
|
||||
|
||||
if (reader->token_count < reader->max_tokens) {
|
||||
|
||||
reader->token_data[reader->token_count] = token;
|
||||
reader->token_count++;
|
||||
}
|
||||
else {
|
||||
/* TODO: expand the storage more intelligently */
|
||||
reader->max_tokens *= 2;
|
||||
reader = GC_REALLOC(reader, sizeof(*reader) * reader->max_tokens);
|
||||
reader->token_data[reader->token_count] = token;
|
||||
reader->token_count++;
|
||||
}
|
||||
return reader;
|
||||
}
|
||||
|
||||
Token* reader_peek(const Reader* reader) {
|
||||
|
||||
return (reader->token_data[reader->position]);
|
||||
}
|
||||
|
||||
Token* reader_next(Reader* reader) {
|
||||
|
||||
Token* tok = reader->token_data[reader->position];
|
||||
|
||||
if (reader->position == -1) {
|
||||
return NULL;
|
||||
}
|
||||
else if (reader->position < reader->token_count) {
|
||||
(reader->position)++;
|
||||
return tok;
|
||||
}
|
||||
else {
|
||||
reader->position = -1;
|
||||
return tok;
|
||||
}
|
||||
}
|
||||
|
||||
void reader_print(Reader* reader) {
|
||||
/* NOTE: needed for debugging the reader only */
|
||||
|
||||
Token* tok;
|
||||
|
||||
for (long i = 0; i < reader->token_count; i++) {
|
||||
|
||||
tok = reader_next(reader);
|
||||
|
||||
switch (tok->type) {
|
||||
case TOKEN_SPECIAL_CHARACTER:
|
||||
printf("special character: %s", tok->data);
|
||||
break;
|
||||
case TOKEN_STRING:
|
||||
printf("string: %s", tok->data);
|
||||
break;
|
||||
case TOKEN_INTEGER:
|
||||
printf("integer: %s", tok->data);
|
||||
break;
|
||||
case TOKEN_FLOAT:
|
||||
printf("float: %s", tok->data);
|
||||
break;
|
||||
case TOKEN_SYMBOL:
|
||||
printf("symbol: %s", tok->data);
|
||||
break;
|
||||
case TOKEN_COMMENT:
|
||||
printf("comment: \"%s\"", tok->data);
|
||||
break;
|
||||
case TOKEN_KEYWORD:
|
||||
printf("keyword: %s", tok->data);
|
||||
break;
|
||||
case TOKEN_TRUE:
|
||||
printf("true: %s", tok->data);
|
||||
break;
|
||||
case TOKEN_FALSE:
|
||||
printf("false: %s", tok->data);
|
||||
break;
|
||||
case TOKEN_NIL:
|
||||
printf("nil: %s", tok->data);
|
||||
break;
|
||||
}
|
||||
/* print an error for any tokens with an error string */
|
||||
tok->error ? printf(" - %s", tok->error) : 0;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* read_str(char* token_string) {
|
||||
|
||||
Reader* reader = tokenize(token_string);
|
||||
|
||||
if (reader->error) {
|
||||
return make_error_fmt("Reader error: %s", reader->error);
|
||||
}
|
||||
else if (reader->token_count == 0) {
|
||||
return make_nil();
|
||||
}
|
||||
else {
|
||||
return read_form(reader);
|
||||
}
|
||||
}
|
||||
|
||||
Reader* tokenize(char* token_string) {
|
||||
|
||||
/* allocate enough space for a Reader */
|
||||
/* TODO: over-allocates space */
|
||||
Reader* reader = reader_make(strlen(token_string));
|
||||
|
||||
for (char* next = token_string; *next != '\0';) {
|
||||
|
||||
Token* token = NULL;
|
||||
|
||||
switch (*next) {
|
||||
/* skip whitespace */
|
||||
case ' ':
|
||||
case ',':
|
||||
case 0x0A: /* newline */
|
||||
next++;
|
||||
token = NULL; /* no token for whitespace */
|
||||
break;
|
||||
|
||||
/* single character token */
|
||||
case '[':
|
||||
case '\\':
|
||||
case ']':
|
||||
case '{':
|
||||
case '}':
|
||||
case '(':
|
||||
case ')':
|
||||
case '\'':
|
||||
case '@':
|
||||
case '`':
|
||||
case '^':
|
||||
next = read_fixed_length_token(next, &token, 1);
|
||||
break;
|
||||
|
||||
/* single or double character token */
|
||||
case '~':
|
||||
if ( *(next + 1) == '@' ) {
|
||||
next = read_fixed_length_token(next, &token, 2);
|
||||
}
|
||||
else {
|
||||
next = read_fixed_length_token(next, &token, 1);
|
||||
}
|
||||
break;
|
||||
|
||||
/* read string of characters within double quotes */
|
||||
case '"':
|
||||
next = read_string_token(next, &token);
|
||||
break;
|
||||
|
||||
/* read a comment - all remaining input until newline */
|
||||
case ';':
|
||||
next = read_comment_token(next, &token);
|
||||
token = NULL; /* skip token for comments */
|
||||
break;
|
||||
|
||||
/* read an integer */
|
||||
case '0':
|
||||
case '1':
|
||||
case '2':
|
||||
case '3':
|
||||
case '4':
|
||||
case '5':
|
||||
case '6':
|
||||
case '7':
|
||||
case '8':
|
||||
case '9':
|
||||
next = read_number_token(next, &token);
|
||||
// next = read_integer_token(next, &token);
|
||||
break;
|
||||
|
||||
/* integer may be prefixed with +/- */
|
||||
case '+':
|
||||
case '-':
|
||||
if (isdigit(next[1])) {
|
||||
next = read_number_token(next, &token);
|
||||
// next = read_integer_token(next, &token);
|
||||
}
|
||||
else { /* if not digits it is part of a symbol */
|
||||
next = read_symbol_token(next, &token);
|
||||
}
|
||||
break;
|
||||
|
||||
/* read keyword */
|
||||
case ':':
|
||||
next = read_keyword_token(next, &token);
|
||||
break;
|
||||
|
||||
/* read anything else as a symbol */
|
||||
default:
|
||||
next = read_symbol_token(next, &token);
|
||||
break;
|
||||
}
|
||||
|
||||
if (!token) {
|
||||
/* if no token was read (whitespace or comments)
|
||||
continue the loop */
|
||||
continue;
|
||||
}
|
||||
else {
|
||||
|
||||
if (token->error) {
|
||||
/* report any errors with an early return */
|
||||
reader = reader_append(reader, token);
|
||||
reader->error = token->error;
|
||||
return reader;
|
||||
}
|
||||
/* otherwise append the token and continue */
|
||||
reader = reader_append(reader, token);
|
||||
}
|
||||
}
|
||||
return reader;
|
||||
}
|
||||
|
||||
char* read_fixed_length_token(char* current, Token** ptoken, int n) {
|
||||
|
||||
*ptoken = token_allocate(current, n, TOKEN_SPECIAL_CHARACTER, NULL);
|
||||
return (current + n);
|
||||
}
|
||||
|
||||
char* read_terminated_token (char* current, Token** ptoken, int token_type) {
|
||||
|
||||
static char* const terminating_characters = " ,[](){};\n";
|
||||
|
||||
/* search for first terminating character */
|
||||
char* end = strpbrk(current, terminating_characters);
|
||||
|
||||
/* if terminating character is not found it implies the end of the string */
|
||||
long token_length = !end ? strlen(current) : (end - current);
|
||||
|
||||
/* next token starts with the terminating character */
|
||||
*ptoken = token_allocate(current, token_length, token_type, NULL);
|
||||
return (current + token_length);
|
||||
}
|
||||
|
||||
char* read_symbol_token (char* current, Token** ptoken) {
|
||||
|
||||
char* next = read_terminated_token(current, ptoken, TOKEN_SYMBOL);
|
||||
|
||||
/* check for reserved symbols */
|
||||
if (strcmp((*ptoken)->data, SYMBOL_NIL) == 0) {
|
||||
(*ptoken)->type = TOKEN_NIL;
|
||||
}
|
||||
else if (strcmp((*ptoken)->data, SYMBOL_TRUE) == 0) {
|
||||
(*ptoken)->type = TOKEN_TRUE;
|
||||
}
|
||||
else if (strcmp((*ptoken)->data, SYMBOL_FALSE) == 0) {
|
||||
(*ptoken)->type = TOKEN_FALSE;
|
||||
}
|
||||
|
||||
/* TODO: check for invalid characters */
|
||||
return next;
|
||||
}
|
||||
|
||||
|
||||
char* read_keyword_token (char* current, Token** ptoken) {
|
||||
|
||||
/* TODO: check for invalid characters */
|
||||
return read_terminated_token(current + 1, ptoken, TOKEN_KEYWORD);
|
||||
}
|
||||
|
||||
char* read_number_token(char* current, Token** ptoken) {
|
||||
|
||||
int has_decimal_point = 0;
|
||||
|
||||
char* next = read_terminated_token(current, ptoken, TOKEN_INTEGER);
|
||||
long token_length = next - current;
|
||||
|
||||
/* first char is either digit or '+' or '-'
|
||||
check the rest consists of valid characters */
|
||||
for (long i = 1; i < token_length; i++) {
|
||||
|
||||
if ((*ptoken)->data[i] == '.' && has_decimal_point) {
|
||||
(*ptoken)->error = "Invalid character reading number";
|
||||
break;
|
||||
}
|
||||
else if ((*ptoken)->data[i] == '.' && !has_decimal_point) {
|
||||
has_decimal_point = 1;
|
||||
(*ptoken)->type = TOKEN_FLOAT;
|
||||
break;
|
||||
}
|
||||
else if (!(isdigit((*ptoken)->data[i]))) {
|
||||
(*ptoken)->error = "Invalid character reading number";
|
||||
break;
|
||||
}
|
||||
}
|
||||
return next;
|
||||
}
|
||||
|
||||
char* read_string_token(char* current, Token** ptoken) {
|
||||
|
||||
char *start, *end, *error = NULL;
|
||||
long token_length = 0;
|
||||
|
||||
start = current + 1;
|
||||
|
||||
while(1) {
|
||||
end = strchr(start, '"'); /* find the next " character */
|
||||
|
||||
/* handle failure to find closing quotes - implies end of input has been reached */
|
||||
if (!end) {
|
||||
end = current + strlen(current);
|
||||
token_length = strlen(current);
|
||||
|
||||
error = "EOF reached with unterminated string";
|
||||
break;
|
||||
}
|
||||
/* if the character preceding the " is a '\' character (escape), need to check if it is escaping the " and if it
|
||||
is then keep searching from the next character */
|
||||
else if ( *(end - 1) == '\\') {
|
||||
|
||||
char* back_ptr = end - 1;
|
||||
while (*back_ptr == '\\') {
|
||||
back_ptr--; /* back up to count the escape characters '\' */
|
||||
}
|
||||
|
||||
long escape_chars = (end - 1) - back_ptr;
|
||||
|
||||
if (escape_chars % 2 == 1) { /* odd number of '\' chars means " is not quoted */
|
||||
start = end + 1; /* so keep searching */
|
||||
} else {
|
||||
/* even number of '\' characters means we found the terminating quote mark */
|
||||
token_length = (end - current - 1); /* quotes are excluded from string token */
|
||||
break;
|
||||
}
|
||||
}
|
||||
else {
|
||||
token_length = (end - current - 1); /* quotes are excluded from string token */
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
char* unescaped_string = unescape_string(current + 1, token_length);
|
||||
*ptoken = token_allocate(unescaped_string, strlen(unescaped_string), TOKEN_STRING, error);
|
||||
|
||||
return (end + 1);
|
||||
}
|
||||
|
||||
char* read_comment_token(char* current, Token** ptoken) {
|
||||
/* comment includes all remaining characters to the next newline */
|
||||
|
||||
/* search for newline character */
|
||||
char* end = strchr(current, 0x0A);
|
||||
|
||||
/* if newline is not found it implies the end of string is reached */
|
||||
long token_chars = !end ? strlen(current) : (end - current);
|
||||
|
||||
*ptoken = token_allocate(current, token_chars, TOKEN_COMMENT, NULL);
|
||||
|
||||
return (current + token_chars + 1); /* next token starts with the char after the newline */
|
||||
}
|
||||
|
||||
MalType* read_form(Reader* reader) {
|
||||
|
||||
if (reader->token_count > 0) {
|
||||
|
||||
Token* tok = reader_peek(reader);
|
||||
if (tok->type == TOKEN_SPECIAL_CHARACTER) {
|
||||
|
||||
switch(tok->data[0]) {
|
||||
|
||||
case '(':
|
||||
return read_list(reader);
|
||||
break;
|
||||
|
||||
case '[':
|
||||
return read_vector(reader);
|
||||
break;
|
||||
|
||||
case '{':
|
||||
return read_hashmap(reader);
|
||||
break;
|
||||
|
||||
case '\'':
|
||||
/* create and return a MalType list (quote read_form) */
|
||||
return make_symbol_list(reader, SYMBOL_QUOTE);
|
||||
break;
|
||||
|
||||
case '`':
|
||||
/* create and return a MalType list (quasiquote read_form) */
|
||||
return make_symbol_list(reader, SYMBOL_QUASIQUOTE);
|
||||
break;
|
||||
|
||||
case '~':
|
||||
if (tok->data[1] == '@') {
|
||||
/* create and return a MalType list (splice-unquote read_form) */
|
||||
return make_symbol_list(reader, SYMBOL_SPLICE_UNQUOTE);
|
||||
}
|
||||
else {
|
||||
/* create and return a MalType list (unquote read_form) */
|
||||
return make_symbol_list(reader, SYMBOL_UNQUOTE);
|
||||
}
|
||||
case '@':
|
||||
/* create and return a MalType list (deref read_form) */
|
||||
return make_symbol_list(reader, SYMBOL_DEREF);
|
||||
|
||||
case '^':
|
||||
/* create and return a MalType list (with-meta <second-form> <first-form>
|
||||
where first form should ne a metadata map and second form is somethingh
|
||||
that can have metadata attached */
|
||||
reader_next(reader);
|
||||
|
||||
/* grab the components of the list */
|
||||
MalType* symbol = make_symbol(SYMBOL_WITH_META);
|
||||
MalType* first_form = read_form(reader);
|
||||
MalType* second_form = read_form(reader);
|
||||
|
||||
/* push the symbol and the following forms onto a list */
|
||||
list lst = NULL;
|
||||
lst = list_push(lst, symbol);
|
||||
lst = list_push(lst, second_form);
|
||||
lst = list_push(lst, first_form);
|
||||
lst = list_reverse(lst);
|
||||
|
||||
return make_list(lst);
|
||||
|
||||
default:
|
||||
/* shouldn't happen */
|
||||
return make_error_fmt("Reader error: Unknown special character '%c'", tok->data[0]);
|
||||
}
|
||||
|
||||
} else { /* Not a special character */
|
||||
return read_atom(reader);
|
||||
}
|
||||
}
|
||||
else { /* no tokens */
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* read_list(Reader* reader) {
|
||||
|
||||
MalType* retval = read_matched_delimiters(reader, '(', ')' );
|
||||
|
||||
if (is_error(retval)) {
|
||||
retval = make_error("Reader error: unbalanced parenthesis '()'");
|
||||
}
|
||||
else {
|
||||
retval->type = MALTYPE_LIST;
|
||||
}
|
||||
return retval;
|
||||
}
|
||||
|
||||
MalType* read_vector(Reader* reader) {
|
||||
|
||||
MalType* retval = read_matched_delimiters(reader, '[', ']' );
|
||||
|
||||
if (is_error(retval)) {
|
||||
retval = make_error("Reader error: unbalanced brackets '[]'");
|
||||
}
|
||||
else {
|
||||
retval->type = MALTYPE_VECTOR;
|
||||
}
|
||||
return retval;
|
||||
}
|
||||
|
||||
MalType* read_hashmap(Reader* reader) {
|
||||
|
||||
MalType* retval = read_matched_delimiters(reader, '{', '}' );
|
||||
|
||||
if (is_error(retval)) {
|
||||
retval = make_error("Reader error: unbalanced braces '{}'");
|
||||
}
|
||||
else if (list_count(retval->value.mal_list)%2 != 0) {
|
||||
retval = make_error("Reader error: missing value in map literal");
|
||||
}
|
||||
else {
|
||||
retval->type = MALTYPE_HASHMAP;
|
||||
}
|
||||
return retval;
|
||||
}
|
||||
|
||||
MalType* read_matched_delimiters(Reader* reader, char start_delimiter, char end_delimiter) {
|
||||
/* TODO: separate implementation of hashmap and vector */
|
||||
|
||||
Token* tok = reader_next(reader);
|
||||
list lst = NULL;
|
||||
|
||||
if (reader_peek(reader)->data[0] == end_delimiter) {
|
||||
reader_next(reader);
|
||||
return make_list(NULL);
|
||||
}
|
||||
else {
|
||||
while (tok->data[0] != end_delimiter) {
|
||||
|
||||
MalType* val = read_form(reader);
|
||||
lst = list_push(lst, (gptr)val);
|
||||
|
||||
tok = reader_peek(reader);
|
||||
|
||||
if (!tok) {
|
||||
/* unbalanced parentheses */
|
||||
return make_error("");
|
||||
}
|
||||
}
|
||||
reader_next(reader);
|
||||
|
||||
return make_list(list_reverse(lst));
|
||||
}
|
||||
}
|
||||
|
||||
MalType* read_atom(Reader* reader) {
|
||||
|
||||
Token* tok = reader_next(reader);
|
||||
|
||||
switch (tok->type) {
|
||||
|
||||
case TOKEN_SPECIAL_CHARACTER:
|
||||
return make_symbol(tok->data);
|
||||
break;
|
||||
|
||||
case TOKEN_COMMENT:
|
||||
return make_error("Error: comment found in token strea");
|
||||
break;
|
||||
|
||||
case TOKEN_STRING:
|
||||
return make_string(tok->data);
|
||||
break;
|
||||
|
||||
case TOKEN_INTEGER:
|
||||
return make_integer(strtol(tok->data, NULL, 10));
|
||||
break;
|
||||
|
||||
case TOKEN_FLOAT:
|
||||
return make_float(atof(tok->data));
|
||||
break;
|
||||
|
||||
case TOKEN_SYMBOL:
|
||||
return make_symbol(tok->data);
|
||||
break;
|
||||
|
||||
case TOKEN_KEYWORD:
|
||||
return make_keyword(tok->data);
|
||||
break;
|
||||
|
||||
case TOKEN_TRUE:
|
||||
return make_true();
|
||||
break;
|
||||
|
||||
case TOKEN_FALSE:
|
||||
return make_false();
|
||||
break;
|
||||
|
||||
case TOKEN_NIL:
|
||||
return make_nil();
|
||||
break;
|
||||
}
|
||||
return make_error("Reader error: Unknown atom type");
|
||||
}
|
||||
|
||||
MalType* make_symbol_list(Reader* reader, char* symbol_name) {
|
||||
|
||||
reader_next(reader);
|
||||
list lst = NULL;
|
||||
|
||||
/* push the symbol and the following form onto the list */
|
||||
lst = list_push(lst, make_symbol(symbol_name));
|
||||
lst = list_push(lst, read_form(reader));
|
||||
|
||||
return make_list(list_reverse(lst));
|
||||
}
|
||||
|
||||
Token* token_allocate(char* str, long num_chars, int type, char* error) {
|
||||
|
||||
/* allocate space for the string */
|
||||
char* data = GC_MALLOC(sizeof(*data) * num_chars + 1); /* include space for null byte */
|
||||
strncpy (data, str, num_chars); /* copy num_chars characters into data */
|
||||
data[num_chars] = '\0'; /* manually add the null byte */
|
||||
|
||||
/* allocate space for the token struct */
|
||||
Token* token = GC_MALLOC(sizeof(*token));
|
||||
token->data = data;
|
||||
token->type = type;
|
||||
token->error = error;
|
||||
|
||||
return token;
|
||||
}
|
||||
|
||||
char* unescape_string(char* str, long length) {
|
||||
|
||||
char* dest = GC_MALLOC(sizeof(*dest)*length + 1);
|
||||
|
||||
long j = 0;
|
||||
for (long i = 0; i < length; i++) {
|
||||
|
||||
/* look for the quoting character */
|
||||
if (str[i] == '\\') {
|
||||
|
||||
switch (str[i+1]) {
|
||||
|
||||
/* replace '\"' with normal '"' */
|
||||
case '"':
|
||||
dest[j++]='"';
|
||||
i++; /* skip extra char */
|
||||
break;
|
||||
|
||||
/* replace '\n' with newline 0x0A */
|
||||
case 'n':
|
||||
dest[j++]= 0x0A;
|
||||
i++; /* skip extra char */
|
||||
break;
|
||||
|
||||
/* replace '\\' with '\' */
|
||||
case '\\':
|
||||
dest[j++]= '\\';
|
||||
i++; /* skip extra char */
|
||||
break;
|
||||
|
||||
default:
|
||||
/* just a '\' symbol so copy it */
|
||||
dest[j++]='\\';
|
||||
}
|
||||
}
|
||||
/* not a quote so copy it */
|
||||
else {
|
||||
dest[j++] = str[i];
|
||||
}
|
||||
}
|
||||
dest[j] = '\0';
|
||||
|
||||
return dest;
|
||||
}
|
57
impls/c.2/reader.h
Normal file
57
impls/c.2/reader.h
Normal file
@ -0,0 +1,57 @@
|
||||
#ifndef _MAL_READER_H
|
||||
#define _MAL_READER_H
|
||||
|
||||
#include "types.h"
|
||||
|
||||
typedef struct Token_s {
|
||||
|
||||
int type;
|
||||
char* data;
|
||||
char* error;
|
||||
|
||||
} Token;
|
||||
|
||||
typedef struct Reader_s {
|
||||
|
||||
long position; // current position in the array
|
||||
long token_count; // number of tokens in the array
|
||||
long max_tokens; // maximum number of tokens the array can hold
|
||||
Token** token_data; // pointer to an array of Tokens
|
||||
char* error; // error message
|
||||
|
||||
} Reader;
|
||||
|
||||
/* reader object */
|
||||
Reader* reader_make(long token_capacity);
|
||||
Reader* reader_append(Reader* reader, Token* token);
|
||||
Token* reader_peek(const Reader* reader);
|
||||
Token* reader_next(Reader* reader);
|
||||
Token* reader_get_at(const Reader* reader, long i);
|
||||
void reader_print(Reader* reader);
|
||||
|
||||
/* tokenizing the input */
|
||||
Reader* tokenize(char* token_string);
|
||||
char* read_fixed_length_token(char* current, Token** ptoken, int n);
|
||||
char* read_string_token(char* current, Token** ptoken);
|
||||
char* read_comment_token(char* current, Token** ptoken);
|
||||
//char* read_integer_token(char* current, Token** ptoken);
|
||||
char* read_number_token(char* current, Token** ptoken);
|
||||
char* read_symbol_token(char* current, Token** ptoken);
|
||||
char* read_keyword_token(char* current, Token** ptoken);
|
||||
|
||||
/* reading the tokens into types */
|
||||
MalType* read_str(char* token_string);
|
||||
MalType* read_form(Reader* reader);
|
||||
MalType* read_atom(Reader* reader);
|
||||
MalType* read_list(Reader* reader);
|
||||
MalType* read_vector(Reader* reader);
|
||||
MalType* read_hashmap(Reader* reader);
|
||||
|
||||
/* utility functions */
|
||||
char* read_terminated_token (char* current, Token** ptoken, int type);
|
||||
MalType* read_matched_delimiters(Reader* reader, char start_delimiter, char end_delimiter);
|
||||
MalType* make_symbol_list(Reader* reader, char* symbol_name);
|
||||
Token* token_allocate(char* str, long num_chars, int type, char* error);
|
||||
char* unescape_string(char* str, long length);
|
||||
|
||||
#endif
|
2
impls/c.2/run
Executable file
2
impls/c.2/run
Executable file
@ -0,0 +1,2 @@
|
||||
#!/bin/bash
|
||||
exec $(dirname $0)/${STEP:-stepA_mal} "${@}"
|
60
impls/c.2/step0_repl.c
Normal file
60
impls/c.2/step0_repl.c
Normal file
@ -0,0 +1,60 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
|
||||
#include <editline/readline.h>
|
||||
#include <editline/history.h>
|
||||
|
||||
#define PROMPT_STRING "user> "
|
||||
|
||||
|
||||
char* READ(char* str) {
|
||||
|
||||
return str;
|
||||
}
|
||||
|
||||
char* EVAL(char* str) {
|
||||
|
||||
return str;
|
||||
}
|
||||
|
||||
void PRINT(char* str) {
|
||||
|
||||
printf("%s\n", str);
|
||||
}
|
||||
|
||||
void rep(char* str) {
|
||||
|
||||
PRINT(EVAL(READ(str)));
|
||||
}
|
||||
|
||||
|
||||
int main(int argc, char** argv) {
|
||||
|
||||
/* Greeting message */
|
||||
puts("Make-a-lisp version 0.0.1\n");
|
||||
puts("Press Ctrl+d to exit\n");
|
||||
|
||||
while (1) {
|
||||
|
||||
/* print prompt and get input*/
|
||||
/* readline allocates memory for input */
|
||||
char* input = readline(PROMPT_STRING);
|
||||
|
||||
/* Check for EOF (Ctrl-D) */
|
||||
if (!input) {
|
||||
printf("\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* add input to history */
|
||||
add_history(input);
|
||||
|
||||
/* call Read-Eval-Print */
|
||||
rep(input);
|
||||
|
||||
/* have to release the memory used by readline */
|
||||
free(input);
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
63
impls/c.2/step1_read_print.c
Normal file
63
impls/c.2/step1_read_print.c
Normal file
@ -0,0 +1,63 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
|
||||
#include <editline/readline.h>
|
||||
#include <editline/history.h>
|
||||
|
||||
#include "types.h"
|
||||
#include "reader.h"
|
||||
#include "printer.h"
|
||||
|
||||
#define PROMPT_STRING "user> "
|
||||
|
||||
MalType* READ(char* str) {
|
||||
|
||||
return read_str(str);
|
||||
}
|
||||
|
||||
MalType* EVAL(MalType* val) {
|
||||
|
||||
return val;
|
||||
}
|
||||
|
||||
void PRINT(MalType* val) {
|
||||
|
||||
char* output = pr_str(val, READABLY);
|
||||
printf("%s\n", output);
|
||||
}
|
||||
|
||||
void rep(char* str) {
|
||||
|
||||
PRINT(EVAL(READ(str)));
|
||||
}
|
||||
|
||||
int main(int argc, char** argv) {
|
||||
|
||||
/* Greeting message */
|
||||
puts("Make-a-lisp version 0.0.2\n");
|
||||
puts("Press Ctrl+d to exit\n");
|
||||
|
||||
while (1) {
|
||||
|
||||
/* print prompt and get input*/
|
||||
/* readline allocates memory for input */
|
||||
char* input = readline(PROMPT_STRING);
|
||||
|
||||
/* Check for EOF (Ctrl-D) */
|
||||
if (!input) {
|
||||
printf("\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* add input to history */
|
||||
add_history(input);
|
||||
|
||||
/* call Read-Eval-Print */
|
||||
rep(input);
|
||||
|
||||
/* have to release the memory used by readline */
|
||||
free(input);
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
305
impls/c.2/step2_eval.c
Normal file
305
impls/c.2/step2_eval.c
Normal file
@ -0,0 +1,305 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <gc.h>
|
||||
|
||||
#include <editline/readline.h>
|
||||
#include <editline/history.h>
|
||||
|
||||
#include "types.h"
|
||||
#include "reader.h"
|
||||
#include "printer.h"
|
||||
#include "env.h"
|
||||
|
||||
#define PROMPT_STRING "user> "
|
||||
|
||||
MalType* READ(char* str) {
|
||||
|
||||
return read_str(str);
|
||||
}
|
||||
|
||||
MalType* EVAL(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
MalType* eval_ast(MalType* ast, Env* env);
|
||||
|
||||
/* NULL */
|
||||
if (!ast) { return make_nil(); }
|
||||
|
||||
/* not a list */
|
||||
if (!is_list(ast)) { return eval_ast(ast, env); }
|
||||
|
||||
/* empty list */
|
||||
if (ast->value.mal_list == NULL) { return ast; }
|
||||
|
||||
/* list */
|
||||
|
||||
/* evaluate the list */
|
||||
MalType* evaluated_list = eval_ast(ast, env);
|
||||
|
||||
if (is_error(evaluated_list)) { return evaluated_list; }
|
||||
|
||||
/* apply the first element of the list to the arguments */
|
||||
list evlst = evaluated_list->value.mal_list;
|
||||
MalType* func = evlst->data;
|
||||
|
||||
if (is_function(func)) {
|
||||
return (*func->value.mal_function)(evlst->next);
|
||||
}
|
||||
else {
|
||||
return make_error_fmt("Error: first item in list is not callable: %s.", \
|
||||
pr_str(func, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
void PRINT(MalType* val) {
|
||||
|
||||
char* output = pr_str(val, READABLY);
|
||||
printf("%s\n", output);
|
||||
}
|
||||
|
||||
void rep(char* str, Env* env) {
|
||||
|
||||
PRINT(EVAL(READ(str), env));
|
||||
}
|
||||
|
||||
int main(int argc, char** argv) {
|
||||
|
||||
MalType* mal_add(list args);
|
||||
MalType* mal_sub(list args);
|
||||
MalType* mal_mul(list args);
|
||||
MalType* mal_div(list args);
|
||||
|
||||
/* Greeting message */
|
||||
puts("Make-a-lisp version 0.0.2\n");
|
||||
puts("Press Ctrl+d to exit\n");
|
||||
|
||||
MalType* func_add = make_function(&mal_add);
|
||||
MalType* func_sub = make_function(&mal_sub);
|
||||
MalType* func_mul = make_function(&mal_mul);
|
||||
MalType* func_div = make_function(&mal_div);
|
||||
|
||||
hashmap g = hashmap_make("+", func_add);
|
||||
g = hashmap_put(g, "-", func_sub);
|
||||
g = hashmap_put(g, "*", func_mul);
|
||||
g = hashmap_put(g, "/", func_div);
|
||||
|
||||
Env* repl_env = GC_MALLOC(sizeof(*repl_env));
|
||||
repl_env->data = g;
|
||||
|
||||
while (1) {
|
||||
|
||||
/* print prompt and get input*/
|
||||
/* readline allocates memory for input */
|
||||
char* input = readline(PROMPT_STRING);
|
||||
|
||||
/* Check for EOF (Ctrl-D) */
|
||||
if (!input) {
|
||||
printf("\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* add input to history */
|
||||
add_history(input);
|
||||
|
||||
/* call Read-Eval-Print */
|
||||
rep(input, repl_env);
|
||||
|
||||
/* have to release the memory used by readline */
|
||||
free(input);
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
MalType* eval_ast(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
list evaluate_list(list lst, Env* env);
|
||||
list evaluate_vector(list lst, Env* env);
|
||||
list evaluate_hashmap(list lst, Env* env);
|
||||
|
||||
if (is_symbol(ast)) {
|
||||
|
||||
MalType* symbol_value = hashmap_get(env->data, ast->value.mal_symbol);
|
||||
|
||||
if (symbol_value) {
|
||||
return symbol_value;
|
||||
} else {
|
||||
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
|
||||
}
|
||||
}
|
||||
else if (is_list(ast)) {
|
||||
|
||||
list result = evaluate_list(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_list(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_vector(ast)) {
|
||||
|
||||
list result = evaluate_vector(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_vector(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_hashmap(ast)) {
|
||||
|
||||
list result = evaluate_hashmap(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_hashmap(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return ast;
|
||||
}
|
||||
}
|
||||
|
||||
list evaluate_list(list lst, Env* env) {
|
||||
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
evlst = list_push(evlst, EVAL(lst->data, env));
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_vector(list lst, Env* env) {
|
||||
/* TODO: implement a real vector */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
evlst = list_push(evlst, EVAL(lst->data, env));
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_hashmap(list lst, Env* env) {
|
||||
/* TODO: implement a real hashmap */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
/* keys are unevaluated */
|
||||
evlst = list_push(evlst, lst->data);
|
||||
lst = lst->next;
|
||||
/* values are evaluated */
|
||||
evlst = list_push(evlst, EVAL(lst->data, env));
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
MalType* mal_add(list args) {
|
||||
|
||||
MalType* result = GC_MALLOC(sizeof(*result));
|
||||
result->type = MALTYPE_INTEGER;
|
||||
|
||||
list arg_list = args;
|
||||
|
||||
long sum = 0;
|
||||
while(arg_list) {
|
||||
|
||||
MalType* val = arg_list->data;
|
||||
/* TODO: check argument type */
|
||||
|
||||
sum = sum + val->value.mal_integer;
|
||||
|
||||
arg_list = arg_list->next;
|
||||
}
|
||||
|
||||
result->value.mal_integer = sum;
|
||||
return result;
|
||||
}
|
||||
|
||||
MalType* mal_sub(list args) {
|
||||
|
||||
long sum;
|
||||
MalType* result = GC_MALLOC(sizeof(*result));
|
||||
result->type = MALTYPE_INTEGER;
|
||||
|
||||
list arg_list = args;
|
||||
if (arg_list) {
|
||||
|
||||
MalType* first_val = arg_list->data;
|
||||
arg_list = arg_list->next;
|
||||
/* TODO: check argument type */
|
||||
|
||||
sum = first_val->value.mal_integer;
|
||||
while(arg_list) {
|
||||
|
||||
MalType* val = arg_list->data;
|
||||
/* TODO: check argument type */
|
||||
|
||||
sum = sum - val->value.mal_integer;
|
||||
|
||||
arg_list = arg_list->next;
|
||||
}
|
||||
}
|
||||
else {
|
||||
sum = 0;
|
||||
}
|
||||
|
||||
result->value.mal_integer = sum;
|
||||
return result;
|
||||
}
|
||||
|
||||
MalType* mal_mul(list args) {
|
||||
|
||||
MalType* result = GC_MALLOC(sizeof(*result));
|
||||
result->type = MALTYPE_INTEGER;
|
||||
|
||||
list arg_list = args;
|
||||
|
||||
long product = 1;
|
||||
while(arg_list) {
|
||||
|
||||
MalType* val = arg_list->data;
|
||||
/* TODO: check argument type */
|
||||
|
||||
product *= val->value.mal_integer;
|
||||
|
||||
arg_list = arg_list->next;
|
||||
}
|
||||
|
||||
result->value.mal_integer = product;
|
||||
return result;
|
||||
}
|
||||
|
||||
MalType* mal_div(list args) {
|
||||
|
||||
long product;
|
||||
MalType* result = GC_MALLOC(sizeof(*result));
|
||||
result->type = MALTYPE_INTEGER;
|
||||
|
||||
list arg_list = args;
|
||||
|
||||
if (arg_list) {
|
||||
MalType* first_val = arg_list->data;
|
||||
/* TODO: check argument type */
|
||||
product = first_val->value.mal_integer;
|
||||
arg_list = arg_list->next;
|
||||
|
||||
while(arg_list) {
|
||||
|
||||
MalType* val = arg_list->data;
|
||||
/* TODO: check argument type */
|
||||
|
||||
product /= (val->value.mal_integer);
|
||||
arg_list = arg_list->next;
|
||||
}
|
||||
} else {
|
||||
product = 1;
|
||||
}
|
||||
result->value.mal_integer = product;
|
||||
return result;
|
||||
}
|
357
impls/c.2/step3_env.c
Normal file
357
impls/c.2/step3_env.c
Normal file
@ -0,0 +1,357 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <gc.h>
|
||||
|
||||
#include <editline/readline.h>
|
||||
#include <editline/history.h>
|
||||
|
||||
#include "types.h"
|
||||
#include "reader.h"
|
||||
#include "printer.h"
|
||||
#include "env.h"
|
||||
|
||||
#define SYMBOL_DEFBANG "def!"
|
||||
#define SYMBOL_LETSTAR "let*"
|
||||
|
||||
#define PROMPT_STRING "user> "
|
||||
|
||||
MalType* READ(char* str) {
|
||||
|
||||
return read_str(str);
|
||||
}
|
||||
|
||||
MalType* EVAL(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
MalType* eval_ast(MalType* ast, Env* env);
|
||||
MalType* eval_defbang(MalType* ast, Env* env);
|
||||
MalType* eval_letstar(MalType* ast, Env* env);
|
||||
|
||||
/* NULL */
|
||||
if (!ast) { return make_nil(); }
|
||||
|
||||
/* not a list */
|
||||
if (!is_list(ast)) { return eval_ast(ast, env); }
|
||||
|
||||
/* empty list */
|
||||
if (ast->value.mal_list == NULL) { return ast; }
|
||||
|
||||
/* list */
|
||||
MalType* first = (ast->value.mal_list)->data;
|
||||
char* symbol = first->value.mal_symbol;
|
||||
|
||||
if (is_symbol(first)) {
|
||||
|
||||
/* handle special symbols first */
|
||||
if (strcmp(symbol, SYMBOL_DEFBANG) == 0) {
|
||||
return eval_defbang(ast, env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) {
|
||||
return eval_letstar(ast, env);
|
||||
}
|
||||
}
|
||||
/* first element is not a special symbol */
|
||||
MalType* evaluated_list = eval_ast(ast, env);
|
||||
|
||||
if (is_error(evaluated_list)) { return evaluated_list; }
|
||||
|
||||
/* apply the first element of the list to the arguments */
|
||||
list evlst = evaluated_list->value.mal_list;
|
||||
MalType* func = evlst->data;
|
||||
|
||||
if (is_function(func)) {
|
||||
return (*func->value.mal_function)(evlst->next);
|
||||
}
|
||||
else {
|
||||
return make_error_fmt("Error: first item in list is not callable: %s.", \
|
||||
pr_str(func, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
void PRINT(MalType* val) {
|
||||
|
||||
char* output = pr_str(val, READABLY);
|
||||
printf("%s\n", output);
|
||||
}
|
||||
|
||||
void rep(char* str, Env* env) {
|
||||
|
||||
PRINT(EVAL(READ(str), env));
|
||||
}
|
||||
|
||||
int main(int argc, char** argv) {
|
||||
|
||||
MalType* mal_add(list args);
|
||||
MalType* mal_sub(list args);
|
||||
MalType* mal_mul(list args);
|
||||
MalType* mal_div(list args);
|
||||
|
||||
/* Greeting message */
|
||||
puts("Make-a-lisp version 0.0.3\n");
|
||||
puts("Press Ctrl+d to exit\n");
|
||||
|
||||
Env* repl_env = env_make(NULL, NULL, NULL, NULL);
|
||||
repl_env = env_set_C_fn(repl_env, "+", mal_add);
|
||||
repl_env = env_set_C_fn(repl_env, "-", mal_sub);
|
||||
repl_env = env_set_C_fn(repl_env, "*", mal_mul);
|
||||
repl_env = env_set_C_fn(repl_env, "/", mal_div);
|
||||
|
||||
while (1) {
|
||||
|
||||
/* print prompt and get input*/
|
||||
/* readline allocates memory for input */
|
||||
char* input = readline(PROMPT_STRING);
|
||||
|
||||
/* Check for EOF (Ctrl-D) */
|
||||
if (!input) {
|
||||
printf("\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* add input to history */
|
||||
add_history(input);
|
||||
|
||||
/* call Read-Eval-Print */
|
||||
rep(input, repl_env);
|
||||
|
||||
/* have to release the memory used by readline */
|
||||
free(input);
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
MalType* eval_ast(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
list evaluate_list(list lst, Env* env);
|
||||
list evaluate_vector(list lst, Env* env);
|
||||
list evaluate_hashmap(list lst, Env* env);
|
||||
|
||||
if (is_symbol(ast)) {
|
||||
|
||||
MalType* symbol_value = env_get(env, ast);
|
||||
|
||||
if (symbol_value) {
|
||||
return symbol_value;
|
||||
} else {
|
||||
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
|
||||
}
|
||||
}
|
||||
else if (is_list(ast)) {
|
||||
|
||||
list result = evaluate_list(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_list(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_vector(ast)) {
|
||||
|
||||
list result = evaluate_vector(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_vector(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_hashmap(ast)) {
|
||||
|
||||
list result = evaluate_hashmap(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_hashmap(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return ast;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_defbang(MalType* ast, Env* env) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
/* TODO: Check the number and types of parameters */
|
||||
MalType* defbang_symbol = lst->data;
|
||||
MalType* defbang_value = lst->next->data;
|
||||
|
||||
MalType* result = EVAL(defbang_value, env);
|
||||
|
||||
if (!is_error(result)) {
|
||||
env_set(env, defbang_symbol, result);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
MalType* eval_letstar(MalType* ast, Env* env) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
lst = lst->next;
|
||||
|
||||
/* TODO: Check the bindings list is valid, has an even number of elements, etc*/
|
||||
Env* letstar_env = env_make(env, NULL, NULL, NULL);
|
||||
|
||||
MalType* letstar_bindings = lst->data;
|
||||
list letstar_bindings_list = letstar_bindings->value.mal_list;
|
||||
|
||||
/* evaluate the bindings */
|
||||
while(letstar_bindings_list) {
|
||||
|
||||
MalType* symbol = letstar_bindings_list->data;
|
||||
MalType* value = letstar_bindings_list->next->data;
|
||||
letstar_env = env_set(letstar_env, symbol, EVAL(value, letstar_env));
|
||||
|
||||
letstar_bindings_list = letstar_bindings_list->next->next; /* pop symbol and value*/
|
||||
}
|
||||
|
||||
/* evaluate the forms in the presence of bindings */
|
||||
MalType* forms = lst->next->data;
|
||||
return EVAL(forms, letstar_env);
|
||||
}
|
||||
|
||||
list evaluate_list(list lst, Env* env) {
|
||||
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
evlst = list_push(evlst, EVAL(lst->data, env));
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_vector(list lst, Env* env) {
|
||||
/* TODO: implement a real vector */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
evlst = list_push(evlst, EVAL(lst->data, env));
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_hashmap(list lst, Env* env) {
|
||||
/* TODO: implement a real hashmap */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
/* keys are unevaluated */
|
||||
evlst = list_push(evlst, lst->data);
|
||||
lst = lst->next;
|
||||
/* values are evaluated */
|
||||
evlst = list_push(evlst, EVAL(lst->data, env));
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
MalType* mal_add(list args) {
|
||||
|
||||
MalType* result = GC_MALLOC(sizeof(*result));
|
||||
result->type = MALTYPE_INTEGER;
|
||||
|
||||
list arg_list = args;
|
||||
|
||||
long sum = 0;
|
||||
while(arg_list) {
|
||||
|
||||
MalType* val = arg_list->data;
|
||||
/* TODO: check argument type */
|
||||
|
||||
sum = sum + val->value.mal_integer;
|
||||
|
||||
arg_list = arg_list->next;
|
||||
}
|
||||
|
||||
result->value.mal_integer = sum;
|
||||
return result;
|
||||
}
|
||||
|
||||
MalType* mal_sub(list args) {
|
||||
|
||||
long sum;
|
||||
MalType* result = GC_MALLOC(sizeof(*result));
|
||||
result->type = MALTYPE_INTEGER;
|
||||
|
||||
list arg_list = args;
|
||||
if (arg_list) {
|
||||
|
||||
MalType* first_val = arg_list->data;
|
||||
arg_list = arg_list->next;
|
||||
/* TODO: check argument type */
|
||||
|
||||
sum = first_val->value.mal_integer;
|
||||
while(arg_list) {
|
||||
|
||||
MalType* val = arg_list->data;
|
||||
/* TODO: check argument type */
|
||||
|
||||
sum = sum - val->value.mal_integer;
|
||||
|
||||
arg_list = arg_list->next;
|
||||
}
|
||||
}
|
||||
else {
|
||||
sum = 0;
|
||||
}
|
||||
|
||||
result->value.mal_integer = sum;
|
||||
return result;
|
||||
}
|
||||
|
||||
MalType* mal_mul(list args) {
|
||||
|
||||
MalType* result = GC_MALLOC(sizeof(*result));
|
||||
result->type = MALTYPE_INTEGER;
|
||||
|
||||
list arg_list = args;
|
||||
|
||||
long product = 1;
|
||||
while(arg_list) {
|
||||
|
||||
MalType* val = arg_list->data;
|
||||
/* TODO: check argument type */
|
||||
|
||||
product *= val->value.mal_integer;
|
||||
|
||||
arg_list = arg_list->next;
|
||||
}
|
||||
|
||||
result->value.mal_integer = product;
|
||||
return result;
|
||||
}
|
||||
|
||||
MalType* mal_div(list args) {
|
||||
|
||||
long product;
|
||||
MalType* result = GC_MALLOC(sizeof(*result));
|
||||
result->type = MALTYPE_INTEGER;
|
||||
|
||||
list arg_list = args;
|
||||
|
||||
if (arg_list) {
|
||||
MalType* first_val = arg_list->data;
|
||||
/* TODO: check argument type */
|
||||
product = first_val->value.mal_integer;
|
||||
arg_list = arg_list->next;
|
||||
|
||||
while(arg_list) {
|
||||
|
||||
MalType* val = arg_list->data;
|
||||
/* TODO: check argument type */
|
||||
|
||||
product /= (val->value.mal_integer);
|
||||
arg_list = arg_list->next;
|
||||
}
|
||||
} else {
|
||||
product = 1;
|
||||
}
|
||||
result->value.mal_integer = product;
|
||||
return result;
|
||||
}
|
490
impls/c.2/step4_if_fn_do.c
Normal file
490
impls/c.2/step4_if_fn_do.c
Normal file
@ -0,0 +1,490 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <gc.h>
|
||||
|
||||
#include <editline/readline.h>
|
||||
#include <editline/history.h>
|
||||
|
||||
#include "types.h"
|
||||
#include "reader.h"
|
||||
#include "printer.h"
|
||||
#include "env.h"
|
||||
#include "core.h"
|
||||
|
||||
#define SYMBOL_DEFBANG "def!"
|
||||
#define SYMBOL_LETSTAR "let*"
|
||||
#define SYMBOL_IF "if"
|
||||
#define SYMBOL_FNSTAR "fn*"
|
||||
#define SYMBOL_DO "do"
|
||||
|
||||
#define PROMPT_STRING "user> "
|
||||
|
||||
MalType* READ(char* str) {
|
||||
|
||||
return read_str(str);
|
||||
}
|
||||
|
||||
MalType* EVAL(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
MalType* eval_ast(MalType* ast, Env* env);
|
||||
MalType* eval_defbang(MalType* ast, Env* env);
|
||||
MalType* eval_letstar(MalType* ast, Env* env);
|
||||
MalType* eval_if(MalType* ast, Env* env);
|
||||
MalType* eval_fnstar(MalType* ast, Env* env);
|
||||
MalType* eval_do(MalType* ast, Env* env);
|
||||
|
||||
/* NULL */
|
||||
if (!ast) { return make_nil(); }
|
||||
|
||||
/* not a list */
|
||||
if (!is_list(ast)) { return eval_ast(ast, env); }
|
||||
|
||||
/* empty list */
|
||||
if (ast->value.mal_list == NULL) { return ast; }
|
||||
|
||||
/* list */
|
||||
MalType* first = (ast->value.mal_list)->data;
|
||||
char* symbol = first->value.mal_symbol;
|
||||
|
||||
if (is_symbol(first)) {
|
||||
|
||||
/* handle special symbols first */
|
||||
if (strcmp(symbol, SYMBOL_DEFBANG) == 0) {
|
||||
return eval_defbang(ast, env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) {
|
||||
return eval_letstar(ast, env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_IF) == 0) {
|
||||
return eval_if(ast, env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) {
|
||||
return eval_fnstar(ast, env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_DO) == 0) {
|
||||
return eval_do(ast, env);
|
||||
}
|
||||
}
|
||||
/* first element is not a special symbol */
|
||||
MalType* evaluated_list = eval_ast(ast, env);
|
||||
|
||||
if (is_error(evaluated_list)) { return evaluated_list; }
|
||||
|
||||
/* apply the first element of the list to the arguments */
|
||||
list evlst = evaluated_list->value.mal_list;
|
||||
MalType* func = evlst->data;
|
||||
|
||||
if (is_function(func)) {
|
||||
return (*func->value.mal_function)(evlst->next);
|
||||
}
|
||||
else if (is_closure(func)) {
|
||||
|
||||
MalClosure* closure = func->value.mal_closure;
|
||||
list params = (closure->parameters)->value.mal_list;
|
||||
|
||||
long param_count = list_count(params);
|
||||
long arg_count = list_count(evlst->next);
|
||||
|
||||
if (param_count > arg_count) {
|
||||
return make_error("too few arguments supplied to function");
|
||||
}
|
||||
else if ((param_count < arg_count) && !closure->more_symbol) {
|
||||
return make_error("too many arguments supplied to function");
|
||||
}
|
||||
else {
|
||||
|
||||
Env* new_env = env_make(closure->env, params, evlst->next, closure->more_symbol);
|
||||
return EVAL(closure->definition, new_env);
|
||||
}
|
||||
}
|
||||
else {
|
||||
return make_error_fmt("Error: first item in list is not callable: %s.", \
|
||||
pr_str(func, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
void PRINT(MalType* val) {
|
||||
|
||||
char* output = pr_str(val, READABLY);
|
||||
printf("%s\n", output);
|
||||
}
|
||||
|
||||
void rep(char* str, Env* env) {
|
||||
|
||||
PRINT(EVAL(READ(str), env));
|
||||
}
|
||||
|
||||
int main(int argc, char** argv) {
|
||||
|
||||
/* Greeting message */
|
||||
puts("Make-a-lisp version 0.0.4\n");
|
||||
puts("Press Ctrl+d to exit\n");
|
||||
|
||||
Env* repl_env = env_make(NULL, NULL, NULL, NULL);
|
||||
|
||||
ns* core = ns_make_core();
|
||||
hashmap mappings = core->mappings;
|
||||
|
||||
while (mappings) {
|
||||
char* symbol = mappings->data;
|
||||
MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data;
|
||||
|
||||
env_set_C_fn(repl_env, symbol, function);
|
||||
|
||||
/* pop symbol and function from hashmap/list */
|
||||
mappings = mappings->next->next;
|
||||
}
|
||||
|
||||
/* add not function */
|
||||
/* not using rep as it prints the result */
|
||||
EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env);
|
||||
|
||||
while (1) {
|
||||
|
||||
/* print prompt and get input*/
|
||||
/* readline allocates memory for input */
|
||||
char* input = readline(PROMPT_STRING);
|
||||
|
||||
/* Check for EOF (Ctrl-D) */
|
||||
if (!input) {
|
||||
printf("\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* add input to history */
|
||||
add_history(input);
|
||||
|
||||
/* call Read-Eval-Print */
|
||||
rep(input, repl_env);
|
||||
|
||||
/* have to release the memory used by readline */
|
||||
free(input);
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
MalType* eval_ast(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
list evaluate_list(list lst, Env* env);
|
||||
list evaluate_vector(list lst, Env* env);
|
||||
list evaluate_hashmap(list lst, Env* env);
|
||||
|
||||
if (is_symbol(ast)) {
|
||||
|
||||
MalType* symbol_value = env_get(env, ast);
|
||||
|
||||
if (symbol_value) {
|
||||
return symbol_value;
|
||||
} else {
|
||||
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
|
||||
}
|
||||
}
|
||||
else if (is_list(ast)) {
|
||||
|
||||
list result = evaluate_list(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_list(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_vector(ast)) {
|
||||
|
||||
list result = evaluate_vector(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_vector(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_hashmap(ast)) {
|
||||
|
||||
list result = evaluate_hashmap(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_hashmap(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return ast;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_defbang(MalType* ast, Env* env) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
if (!lst || !lst->next || lst->next->next) {
|
||||
return make_error_fmt("'def!': expected exactly two arguments");
|
||||
}
|
||||
|
||||
MalType* defbang_symbol = lst->data;
|
||||
|
||||
if (!is_symbol(defbang_symbol)) {
|
||||
return make_error_fmt("'def!': expected symbol for first argument");
|
||||
}
|
||||
|
||||
MalType* defbang_value = lst->next->data;
|
||||
MalType* result = EVAL(defbang_value, env);
|
||||
|
||||
if (!is_error(result)){
|
||||
env = env_set(env, defbang_symbol, result);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
MalType* eval_letstar(MalType* ast, Env* env) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
return make_error("'let*': missing bindings list");
|
||||
}
|
||||
|
||||
MalType* bindings = lst->next->data;
|
||||
MalType* forms = lst->next->next ? lst->next->next->data : make_nil();
|
||||
|
||||
if (!is_sequential(bindings)) {
|
||||
return make_error("'let*': first argument is not list or vector");
|
||||
}
|
||||
|
||||
list bindings_list = bindings->value.mal_list;
|
||||
if (list_count(bindings_list) % 2 == 1) {
|
||||
return make_error("'let*': expected an even number of binding pairs");
|
||||
}
|
||||
|
||||
Env* letstar_env = env_make(env, NULL, NULL, NULL);
|
||||
|
||||
/* evaluate the bindings */
|
||||
while(bindings_list) {
|
||||
|
||||
MalType* symbol = bindings_list->data;
|
||||
MalType* value = EVAL(bindings_list->next->data, letstar_env);
|
||||
|
||||
/* early return from error */
|
||||
if (is_error(value)) { return value; }
|
||||
|
||||
env_set(letstar_env, symbol, value);
|
||||
bindings_list = bindings_list->next->next;
|
||||
}
|
||||
return EVAL(forms, letstar_env);
|
||||
}
|
||||
|
||||
MalType* eval_if(MalType* ast, Env* env) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
if (!lst->next || !lst->next->next) {
|
||||
return make_error("'if': too few arguments");
|
||||
}
|
||||
|
||||
if (lst->next->next->next && lst->next->next->next->next) {
|
||||
return make_error("'if': too many arguments");
|
||||
}
|
||||
|
||||
MalType* condition = EVAL(lst->next->data, env);
|
||||
|
||||
if (is_error(condition)) { return condition; }
|
||||
|
||||
if (is_false(condition) || is_nil(condition)) {
|
||||
|
||||
/* check whether false branch is present */
|
||||
if (lst->next->next->next) {
|
||||
return EVAL(lst->next->next->next->data, env);
|
||||
}
|
||||
else {
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
} else {
|
||||
return EVAL(lst->next->next->data, env);
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_fnstar(MalType* ast, Env* env) {
|
||||
|
||||
/* forward reference */
|
||||
MalType* regularise_parameters(list* params, MalType** more);
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
return make_error("'fn*': missing argument list");
|
||||
}
|
||||
else if (!lst->next->next) {
|
||||
return make_error("'fn*': missing function body");
|
||||
}
|
||||
|
||||
MalType* params = lst->next->data;
|
||||
list params_list = params->value.mal_list;
|
||||
|
||||
MalType* more_symbol = NULL;
|
||||
|
||||
MalType* result = regularise_parameters(¶ms_list, &more_symbol);
|
||||
if (is_error(result)) { return result; }
|
||||
|
||||
MalType* definition = lst->next->next->data;
|
||||
MalType* regular_params = make_list(params_list);
|
||||
|
||||
return make_closure(env, regular_params, definition, more_symbol);
|
||||
}
|
||||
|
||||
MalType* eval_do(MalType* ast, Env* env) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
/* handle empty 'do' */
|
||||
if (!lst->next) { return make_nil(); }
|
||||
|
||||
/* evaluate all but the last form */
|
||||
lst = lst->next;
|
||||
while (lst->next) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
/* return error early */
|
||||
if (is_error(val)) { return val; }
|
||||
lst = lst->next;
|
||||
}
|
||||
/* return the last value */
|
||||
return EVAL(lst->data, env);
|
||||
}
|
||||
|
||||
list evaluate_list(list lst, Env* env) {
|
||||
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_vector(list lst, Env* env) {
|
||||
/* TODO: implement a real vector */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_hashmap(list lst, Env* env) {
|
||||
/* TODO: implement a real hashmap */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
/* keys are unevaluated */
|
||||
evlst = list_push(evlst, lst->data);
|
||||
lst = lst->next;
|
||||
|
||||
/* values are evaluated */
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
MalType* regularise_parameters(list* args, MalType** more_symbol) {
|
||||
|
||||
/* forward reference */
|
||||
char* symbol_fn(gptr data);
|
||||
|
||||
list regular_args = NULL;
|
||||
while (*args) {
|
||||
|
||||
MalType* val = (*args)->data;
|
||||
|
||||
if (!is_symbol(val)) {
|
||||
return make_error_fmt("non-symbol found in fn argument list '%s'", \
|
||||
pr_str(val, UNREADABLY));
|
||||
}
|
||||
|
||||
if (val->value.mal_symbol[0] == '&') {
|
||||
|
||||
/* & is found but there is no symbol */
|
||||
if (val->value.mal_symbol[1] == '\0' && !(*args)->next) {
|
||||
return make_error("missing symbol after '&' in argument list");
|
||||
}
|
||||
/* & is found and there is a single symbol after */
|
||||
else if ((val->value.mal_symbol[1] == '\0' && (*args)->next &&
|
||||
is_symbol((*args)->next->data) && !(*args)->next->next)) {
|
||||
|
||||
/* TODO: check symbol is no a duplicate of one already on the list */
|
||||
*more_symbol = (*args)->next->data;
|
||||
break;
|
||||
}
|
||||
/* & is found and there extra symbols after */
|
||||
else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) {
|
||||
return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \
|
||||
pr_str((*args)->next->data, UNREADABLY), \
|
||||
pr_str((*args)->next->next->data, UNREADABLY));
|
||||
}
|
||||
/* & is found as part of the symbol and no other symbols */
|
||||
else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) {
|
||||
*more_symbol = make_symbol((val->value.mal_symbol + 1));
|
||||
break;
|
||||
}
|
||||
/* & is found as part of the symbol but there are other symbols after */
|
||||
else if (val->value.mal_symbol[1] != '\0' && (*args)->next) {
|
||||
return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \
|
||||
pr_str(val, UNREADABLY), \
|
||||
pr_str((*args)->next->data, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
/* & is not found - add the symbol to the regular argument list */
|
||||
else {
|
||||
|
||||
if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) {
|
||||
return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY));
|
||||
}
|
||||
else {
|
||||
regular_args = list_push(regular_args, val);
|
||||
}
|
||||
}
|
||||
*args = (*args)->next;
|
||||
}
|
||||
|
||||
*args = list_reverse(regular_args);
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
char* symbol_fn(gptr data) {
|
||||
MalType* val = data;
|
||||
return (val->value.mal_symbol);
|
||||
}
|
||||
|
||||
/* silence the compiler after swap!, apply, and map are added to the core */
|
||||
MalType* apply(MalType* ast, Env* env) {
|
||||
return make_nil();
|
||||
}
|
532
impls/c.2/step5_tco.c
Normal file
532
impls/c.2/step5_tco.c
Normal file
@ -0,0 +1,532 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <gc.h>
|
||||
|
||||
#include <editline/readline.h>
|
||||
#include <editline/history.h>
|
||||
|
||||
#include "types.h"
|
||||
#include "reader.h"
|
||||
#include "printer.h"
|
||||
#include "env.h"
|
||||
#include "core.h"
|
||||
|
||||
#define SYMBOL_DEFBANG "def!"
|
||||
#define SYMBOL_LETSTAR "let*"
|
||||
#define SYMBOL_IF "if"
|
||||
#define SYMBOL_FNSTAR "fn*"
|
||||
#define SYMBOL_DO "do"
|
||||
|
||||
#define PROMPT_STRING "user> "
|
||||
|
||||
MalType* READ(char* str) {
|
||||
|
||||
return read_str(str);
|
||||
}
|
||||
|
||||
MalType* EVAL(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
MalType* eval_ast(MalType* ast, Env* env);
|
||||
MalType* eval_defbang(MalType* ast, Env** env);
|
||||
void eval_letstar(MalType** ast, Env** env);
|
||||
void eval_if(MalType** ast, Env** env);
|
||||
MalType* eval_fnstar(MalType* ast, Env* env);
|
||||
MalType* eval_do(MalType* ast, Env* env);
|
||||
|
||||
/* Use goto to jump here rather than calling eval for tail-call elimination */
|
||||
TCE_entry_point:
|
||||
|
||||
/* NULL */
|
||||
if (!ast) { return make_nil(); }
|
||||
|
||||
/* not a list */
|
||||
if (!is_list(ast)) { return eval_ast(ast, env); }
|
||||
|
||||
/* empty list */
|
||||
if (ast->value.mal_list == NULL) { return ast; }
|
||||
|
||||
/* list */
|
||||
MalType* first = (ast->value.mal_list)->data;
|
||||
char* symbol = first->value.mal_symbol;
|
||||
|
||||
if (is_symbol(first)) {
|
||||
|
||||
/* handle special symbols first */
|
||||
if (strcmp(symbol, SYMBOL_DEFBANG) == 0) {
|
||||
return eval_defbang(ast, &env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
eval_letstar(&ast, &env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_IF) == 0) {
|
||||
|
||||
/* TCE - modify ast directly and jump back to eval */
|
||||
eval_if(&ast, &env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) {
|
||||
return eval_fnstar(ast, env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_DO) == 0) {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
ast = eval_do(ast, env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
}
|
||||
/* first element is not a special symbol */
|
||||
MalType* evaluated_list = eval_ast(ast, env);
|
||||
|
||||
/* apply the first element of the list to the arguments */
|
||||
list evlst = evaluated_list->value.mal_list;
|
||||
MalType* func = evlst->data;
|
||||
|
||||
if (is_function(func)) {
|
||||
return (*func->value.mal_function)(evlst->next);
|
||||
}
|
||||
else if (is_closure(func)) {
|
||||
|
||||
MalClosure* closure = func->value.mal_closure;
|
||||
list params = (closure->parameters)->value.mal_list;
|
||||
|
||||
long param_count = list_count(params);
|
||||
long arg_count = list_count(evlst->next);
|
||||
|
||||
if (param_count > arg_count) {
|
||||
return make_error("too few arguments supplied to function");
|
||||
}
|
||||
else if ((param_count < arg_count) && !closure->more_symbol) {
|
||||
return make_error("too many arguments supplied to function");
|
||||
}
|
||||
else {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
env = env_make(closure->env, params, evlst->next, closure->more_symbol);
|
||||
ast = func->value.mal_closure->definition;
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return make_error_fmt("first item in list is not callable: '%s'", \
|
||||
pr_str(func, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
void PRINT(MalType* val) {
|
||||
|
||||
char* output = pr_str(val, READABLY);
|
||||
printf("%s\n", output);
|
||||
}
|
||||
|
||||
void rep(char* str, Env* env) {
|
||||
|
||||
PRINT(EVAL(READ(str), env));
|
||||
}
|
||||
|
||||
int main(int argc, char** argv) {
|
||||
|
||||
/* Greeting message */
|
||||
puts("Make-a-lisp version 0.0.5\n");
|
||||
puts("Press Ctrl+d to exit\n");
|
||||
|
||||
Env* repl_env = env_make(NULL, NULL, NULL, NULL);
|
||||
|
||||
ns* core = ns_make_core();
|
||||
hashmap mappings = core->mappings;
|
||||
|
||||
while (mappings) {
|
||||
char* symbol = mappings->data;
|
||||
MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data;
|
||||
|
||||
env_set_C_fn(repl_env, symbol, function);
|
||||
|
||||
/* pop symbol and function from hashmap/list */
|
||||
mappings = mappings->next->next;
|
||||
}
|
||||
|
||||
/* add not function */
|
||||
/* not using rep as it prints the result */
|
||||
EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env);
|
||||
|
||||
while (1) {
|
||||
|
||||
/* print prompt and get input*/
|
||||
/* readline allocates memory for input */
|
||||
char* input = readline(PROMPT_STRING);
|
||||
|
||||
/* Check for EOF (Ctrl-D) */
|
||||
if (!input) {
|
||||
printf("\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* add input to history */
|
||||
add_history(input);
|
||||
|
||||
/* call Read-Eval-Print */
|
||||
rep(input, repl_env);
|
||||
|
||||
/* have to release the memory used by readline */
|
||||
free(input);
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
MalType* eval_ast(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
list evaluate_list(list lst, Env* env);
|
||||
list evaluate_vector(list lst, Env* env);
|
||||
list evaluate_hashmap(list lst, Env* env);
|
||||
|
||||
if (is_symbol(ast)) {
|
||||
|
||||
MalType* symbol_value = env_get(env, ast);
|
||||
|
||||
if (symbol_value) {
|
||||
return symbol_value;
|
||||
} else {
|
||||
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
|
||||
}
|
||||
}
|
||||
else if (is_list(ast)) {
|
||||
|
||||
list result = evaluate_list(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_list(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_vector(ast)) {
|
||||
|
||||
list result = evaluate_vector(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_vector(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_hashmap(ast)) {
|
||||
|
||||
list result = evaluate_hashmap(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_hashmap(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return ast;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_defbang(MalType* ast, Env** env) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
if (!lst || !lst->next || lst->next->next) {
|
||||
return make_error_fmt("'def!': expected exactly two arguments");
|
||||
}
|
||||
|
||||
MalType* defbang_symbol = lst->data;
|
||||
|
||||
if (!is_symbol(defbang_symbol)) {
|
||||
return make_error_fmt("'def!': expected symbol for first argument");
|
||||
}
|
||||
|
||||
MalType* defbang_value = lst->next->data;
|
||||
MalType* result = EVAL(defbang_value, *env);
|
||||
|
||||
if (!is_error(result)){
|
||||
*env = env_set(*env, defbang_symbol, result);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
void eval_letstar(MalType** ast, Env** env) {
|
||||
|
||||
list lst = (*ast)->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
*ast = make_error("'let*': missing bindings list");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* bindings = lst->next->data;
|
||||
MalType* forms = lst->next->next ? lst->next->next->data : make_nil();
|
||||
|
||||
if (!is_sequential(bindings)) {
|
||||
*ast = make_error("'let*': first argument is not list or vector");
|
||||
return;
|
||||
}
|
||||
|
||||
list bindings_list = bindings->value.mal_list;
|
||||
if (list_count(bindings_list) % 2 == 1) {
|
||||
*ast = make_error("'let*': expected an even number of binding pairs");
|
||||
return;
|
||||
}
|
||||
|
||||
Env* letstar_env = env_make(*env, NULL, NULL, NULL);
|
||||
|
||||
/* evaluate the bindings */
|
||||
while(bindings_list) {
|
||||
|
||||
MalType* symbol = bindings_list->data;
|
||||
MalType* value = EVAL(bindings_list->next->data, letstar_env);
|
||||
|
||||
/* early return from error */
|
||||
if (is_error(value)) {
|
||||
*ast = value;
|
||||
return;
|
||||
}
|
||||
|
||||
env_set(letstar_env, symbol, value);
|
||||
bindings_list = bindings_list->next->next;
|
||||
}
|
||||
|
||||
*env = letstar_env;
|
||||
*ast = forms;
|
||||
return;
|
||||
}
|
||||
|
||||
void eval_if(MalType** ast, Env** env) {
|
||||
|
||||
list lst = (*ast)->value.mal_list;
|
||||
|
||||
if (!lst->next || !lst->next->next) {
|
||||
*ast = make_error("'if': too few arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
if (lst->next->next->next && lst->next->next->next->next) {
|
||||
*ast = make_error("'if': too many arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* condition = EVAL(lst->next->data, *env);
|
||||
|
||||
if (is_error(condition)) {
|
||||
*ast = condition;
|
||||
return;
|
||||
}
|
||||
|
||||
if (is_false(condition) || is_nil(condition)) {
|
||||
|
||||
/* check whether false branch is present */
|
||||
if (lst->next->next->next) {
|
||||
*ast = lst->next->next->next->data;
|
||||
return;
|
||||
}
|
||||
else {
|
||||
*ast = make_nil();
|
||||
return;
|
||||
}
|
||||
|
||||
} else {
|
||||
*ast = lst->next->next->data;
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_fnstar(MalType* ast, Env* env) {
|
||||
|
||||
/* forward reference */
|
||||
MalType* regularise_parameters(list* params, MalType** more);
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
return make_error("'fn*': missing argument list");
|
||||
}
|
||||
else if (!lst->next->next) {
|
||||
return make_error("'fn*': missing function body");
|
||||
}
|
||||
|
||||
MalType* params = lst->next->data;
|
||||
list params_list = params->value.mal_list;
|
||||
|
||||
MalType* more_symbol = NULL;
|
||||
|
||||
MalType* result = regularise_parameters(¶ms_list, &more_symbol);
|
||||
if (is_error(result)) { return result; }
|
||||
|
||||
MalType* definition = lst->next->next->data;
|
||||
MalType* regular_params = make_list(params_list);
|
||||
|
||||
return make_closure(env, regular_params, definition, more_symbol);
|
||||
}
|
||||
|
||||
MalType* eval_do(MalType* ast, Env* env) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
/* handle empty 'do' */
|
||||
if (!lst->next) {
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
/* evaluate all but the last form */
|
||||
lst = lst->next;
|
||||
while (lst->next) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
/* return error early */
|
||||
if (is_error(val)) {
|
||||
return val;
|
||||
}
|
||||
lst = lst->next;
|
||||
}
|
||||
/* return the last form for TCE evaluation */
|
||||
return lst->data;
|
||||
}
|
||||
|
||||
list evaluate_list(list lst, Env* env) {
|
||||
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_vector(list lst, Env* env) {
|
||||
/* TODO: implement a real vector */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_hashmap(list lst, Env* env) {
|
||||
/* TODO: implement a real hashmap */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
/* keys are unevaluated */
|
||||
evlst = list_push(evlst, lst->data);
|
||||
lst = lst->next;
|
||||
|
||||
/* values are evaluated */
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
MalType* regularise_parameters(list* args, MalType** more_symbol) {
|
||||
|
||||
/* forward reference */
|
||||
char* symbol_fn(gptr data);
|
||||
|
||||
list regular_args = NULL;
|
||||
while (*args) {
|
||||
|
||||
MalType* val = (*args)->data;
|
||||
|
||||
if (!is_symbol(val)) {
|
||||
return make_error_fmt("non-symbol found in fn argument list '%s'", \
|
||||
pr_str(val, UNREADABLY));
|
||||
}
|
||||
|
||||
if (val->value.mal_symbol[0] == '&') {
|
||||
|
||||
/* & is found but there is no symbol */
|
||||
if (val->value.mal_symbol[1] == '\0' && !(*args)->next) {
|
||||
return make_error("missing symbol after '&' in argument list");
|
||||
}
|
||||
/* & is found and there is a single symbol after */
|
||||
else if ((val->value.mal_symbol[1] == '\0' && (*args)->next &&
|
||||
is_symbol((*args)->next->data) && !(*args)->next->next)) {
|
||||
|
||||
/* TODO: check symbol is no a duplicate of one already on the list */
|
||||
*more_symbol = (*args)->next->data;
|
||||
break;
|
||||
}
|
||||
/* & is found and there extra symbols after */
|
||||
else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) {
|
||||
return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \
|
||||
pr_str((*args)->next->data, UNREADABLY), \
|
||||
pr_str((*args)->next->next->data, UNREADABLY));
|
||||
}
|
||||
/* & is found as part of the symbol and no other symbols */
|
||||
else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) {
|
||||
*more_symbol = make_symbol((val->value.mal_symbol + 1));
|
||||
break;
|
||||
}
|
||||
/* & is found as part of the symbol but there are other symbols after */
|
||||
else if (val->value.mal_symbol[1] != '\0' && (*args)->next) {
|
||||
return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \
|
||||
pr_str(val, UNREADABLY), \
|
||||
pr_str((*args)->next->data, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
/* & is not found - add the symbol to the regular argument list */
|
||||
else {
|
||||
|
||||
if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) {
|
||||
return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY));
|
||||
}
|
||||
else {
|
||||
regular_args = list_push(regular_args, val);
|
||||
}
|
||||
}
|
||||
*args = (*args)->next;
|
||||
}
|
||||
|
||||
*args = list_reverse(regular_args);
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
char* symbol_fn(gptr data) {
|
||||
MalType* val = data;
|
||||
return (val->value.mal_symbol);
|
||||
}
|
||||
|
||||
/* silence the compiler after swap!, apply, and map
|
||||
are added to the core */
|
||||
MalType* apply(MalType* ast, Env* env) {
|
||||
return make_nil();
|
||||
}
|
586
impls/c.2/step6_file.c
Normal file
586
impls/c.2/step6_file.c
Normal file
@ -0,0 +1,586 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <gc.h>
|
||||
|
||||
#include <editline/readline.h>
|
||||
#include <editline/history.h>
|
||||
|
||||
#include "types.h"
|
||||
#include "reader.h"
|
||||
#include "printer.h"
|
||||
#include "env.h"
|
||||
#include "core.h"
|
||||
|
||||
#define SYMBOL_DEFBANG "def!"
|
||||
#define SYMBOL_LETSTAR "let*"
|
||||
#define SYMBOL_IF "if"
|
||||
#define SYMBOL_FNSTAR "fn*"
|
||||
#define SYMBOL_DO "do"
|
||||
|
||||
#define PROMPT_STRING "user> "
|
||||
|
||||
MalType* READ(char* str) {
|
||||
|
||||
return read_str(str);
|
||||
}
|
||||
|
||||
MalType* EVAL(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
MalType* eval_ast(MalType* ast, Env* env);
|
||||
MalType* eval_defbang(MalType* ast, Env** env);
|
||||
void eval_letstar(MalType** ast, Env** env);
|
||||
void eval_if(MalType** ast, Env** env);
|
||||
MalType* eval_fnstar(MalType* ast, Env* env);
|
||||
MalType* eval_do(MalType* ast, Env* env);
|
||||
|
||||
/* Use goto to jump here rather than calling eval for tail-call elimination */
|
||||
TCE_entry_point:
|
||||
|
||||
/* NULL */
|
||||
if (!ast) { return make_nil(); }
|
||||
|
||||
/* not a list */
|
||||
if (!is_list(ast)) { return eval_ast(ast, env); }
|
||||
|
||||
/* empty list */
|
||||
if (ast->value.mal_list == NULL) { return ast; }
|
||||
|
||||
/* list */
|
||||
MalType* first = (ast->value.mal_list)->data;
|
||||
char* symbol = first->value.mal_symbol;
|
||||
|
||||
if (is_symbol(first)) {
|
||||
|
||||
/* handle special symbols first */
|
||||
if (strcmp(symbol, SYMBOL_DEFBANG) == 0) {
|
||||
return eval_defbang(ast, &env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
eval_letstar(&ast, &env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_DO) == 0) {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
ast = eval_do(ast, env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_IF) == 0) {
|
||||
|
||||
/* TCE - modify ast directly and jump back to eval */
|
||||
eval_if(&ast, &env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) {
|
||||
return eval_fnstar(ast, env);
|
||||
}
|
||||
}
|
||||
/* first element is not a special symbol */
|
||||
MalType* evaluated_list = eval_ast(ast, env);
|
||||
|
||||
if (is_error(evaluated_list)) { return evaluated_list; }
|
||||
|
||||
/* apply the first element of the list to the arguments */
|
||||
list evlst = evaluated_list->value.mal_list;
|
||||
MalType* func = evlst->data;
|
||||
|
||||
if (is_function(func)) {
|
||||
return (*func->value.mal_function)(evlst->next);
|
||||
}
|
||||
else if (is_closure(func)) {
|
||||
|
||||
MalClosure* closure = func->value.mal_closure;
|
||||
list params = (closure->parameters)->value.mal_list;
|
||||
|
||||
long param_count = list_count(params);
|
||||
long arg_count = list_count(evlst->next);
|
||||
|
||||
if (param_count > arg_count) {
|
||||
return make_error("too few arguments supplied to function");
|
||||
}
|
||||
else if ((param_count < arg_count) && !closure->more_symbol) {
|
||||
return make_error("too many arguments supplied to function");
|
||||
}
|
||||
else {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
env = env_make(closure->env, params, evlst->next, closure->more_symbol);
|
||||
ast = func->value.mal_closure->definition;
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return make_error_fmt("first item in list is not callable: '%s'", \
|
||||
pr_str(func, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
void PRINT(MalType* val) {
|
||||
|
||||
char* output = pr_str(val, READABLY);
|
||||
printf("%s\n", output);
|
||||
}
|
||||
|
||||
void rep(char* str, Env* env) {
|
||||
|
||||
PRINT(EVAL(READ(str), env));
|
||||
}
|
||||
|
||||
/* declare as global so it can be accessed by mal_eval */
|
||||
Env* global_env;
|
||||
|
||||
MalType* mal_eval(list args) {
|
||||
|
||||
MalType* ast = args->data;
|
||||
return EVAL(ast, global_env);
|
||||
}
|
||||
|
||||
int main(int argc, char** argv) {
|
||||
|
||||
Env* repl_env = env_make(NULL, NULL, NULL, NULL);
|
||||
global_env = repl_env;
|
||||
|
||||
ns* core = ns_make_core();
|
||||
hashmap mappings = core->mappings;
|
||||
|
||||
while (mappings) {
|
||||
char* symbol = mappings->data;
|
||||
MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data;
|
||||
|
||||
env_set_C_fn(repl_env, symbol, function);
|
||||
|
||||
/* pop symbol and function from hashmap/list */
|
||||
mappings = mappings->next->next;
|
||||
}
|
||||
|
||||
env_set_C_fn(repl_env, "eval", mal_eval);
|
||||
|
||||
/* add functions written in mal - not using rep as it prints the result */
|
||||
EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env);
|
||||
EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env);
|
||||
|
||||
|
||||
/* make command line arguments available in the environment */
|
||||
list lst = NULL;
|
||||
for (int i = 2; i < argc; i++) {
|
||||
lst = list_push(lst, make_string(argv[i]));
|
||||
}
|
||||
env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst)));
|
||||
|
||||
/* run in script mode if a filename is given */
|
||||
if (argc > 1) {
|
||||
|
||||
/* first argument on command line is filename */
|
||||
char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]);
|
||||
EVAL(READ(load_command), repl_env);
|
||||
}
|
||||
/* run in repl mode when no cmd line args */
|
||||
else {
|
||||
|
||||
/* Greeting message */
|
||||
puts("Make-a-lisp version 0.0.6\n");
|
||||
puts("Press Ctrl+d to exit\n");
|
||||
|
||||
while (1) {
|
||||
|
||||
/* print prompt and get input*/
|
||||
/* readline allocates memory for input */
|
||||
char* input = readline(PROMPT_STRING);
|
||||
|
||||
/* Check for EOF (Ctrl-D) */
|
||||
if (!input) {
|
||||
printf("\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* add input to history */
|
||||
add_history(input);
|
||||
|
||||
/* call Read-Eval-Print */
|
||||
rep(input, repl_env);
|
||||
|
||||
/* have to release the memory used by readline */
|
||||
free(input);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
MalType* eval_ast(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
list evaluate_list(list lst, Env* env);
|
||||
list evaluate_vector(list lst, Env* env);
|
||||
list evaluate_hashmap(list lst, Env* env);
|
||||
|
||||
if (is_symbol(ast)) {
|
||||
|
||||
MalType* symbol_value = env_get(env, ast);
|
||||
|
||||
if (symbol_value) {
|
||||
return symbol_value;
|
||||
} else {
|
||||
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
|
||||
}
|
||||
}
|
||||
else if (is_list(ast)) {
|
||||
|
||||
list result = evaluate_list(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_list(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_vector(ast)) {
|
||||
|
||||
list result = evaluate_vector(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_vector(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_hashmap(ast)) {
|
||||
|
||||
list result = evaluate_hashmap(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_hashmap(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return ast;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_defbang(MalType* ast, Env** env) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
if (!lst || !lst->next || lst->next->next) {
|
||||
return make_error_fmt("'def!': expected exactly two arguments");
|
||||
}
|
||||
|
||||
MalType* defbang_symbol = lst->data;
|
||||
|
||||
if (!is_symbol(defbang_symbol)) {
|
||||
return make_error_fmt("'def!': expected symbol for first argument");
|
||||
}
|
||||
|
||||
MalType* defbang_value = lst->next->data;
|
||||
MalType* result = EVAL(defbang_value, *env);
|
||||
|
||||
if (!is_error(result)){
|
||||
*env = env_set(*env, defbang_symbol, result);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
void eval_letstar(MalType** ast, Env** env) {
|
||||
|
||||
list lst = (*ast)->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
*ast = make_error("'let*': missing bindings list");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* bindings = lst->next->data;
|
||||
MalType* forms = lst->next->next ? lst->next->next->data : make_nil();
|
||||
|
||||
if (!is_sequential(bindings)) {
|
||||
*ast = make_error("'let*': first argument is not list or vector");
|
||||
return;
|
||||
}
|
||||
|
||||
list bindings_list = bindings->value.mal_list;
|
||||
if (list_count(bindings_list) % 2 == 1) {
|
||||
*ast = make_error("'let*': expected an even number of binding pairs");
|
||||
return;
|
||||
}
|
||||
|
||||
Env* letstar_env = env_make(*env, NULL, NULL, NULL);
|
||||
|
||||
/* evaluate the bindings */
|
||||
while(bindings_list) {
|
||||
|
||||
MalType* symbol = bindings_list->data;
|
||||
MalType* value = EVAL(bindings_list->next->data, letstar_env);
|
||||
|
||||
/* early return from error */
|
||||
if (is_error(value)) {
|
||||
*ast = value;
|
||||
return;
|
||||
}
|
||||
|
||||
env_set(letstar_env, symbol, value);
|
||||
bindings_list = bindings_list->next->next;
|
||||
}
|
||||
|
||||
*env = letstar_env;
|
||||
*ast = forms;
|
||||
return;
|
||||
}
|
||||
|
||||
void eval_if(MalType** ast, Env** env) {
|
||||
|
||||
list lst = (*ast)->value.mal_list;
|
||||
|
||||
if (!lst->next || !lst->next->next) {
|
||||
*ast = make_error("'if': too few arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
if (lst->next->next->next && lst->next->next->next->next) {
|
||||
*ast = make_error("'if': too many arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* condition = EVAL(lst->next->data, *env);
|
||||
|
||||
if (is_error(condition)) {
|
||||
*ast = condition;
|
||||
return;
|
||||
}
|
||||
|
||||
if (is_false(condition) || is_nil(condition)) {
|
||||
|
||||
/* check whether false branch is present */
|
||||
if (lst->next->next->next) {
|
||||
*ast = lst->next->next->next->data;
|
||||
return;
|
||||
}
|
||||
else {
|
||||
*ast = make_nil();
|
||||
return;
|
||||
}
|
||||
|
||||
} else {
|
||||
*ast = lst->next->next->data;
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_fnstar(MalType* ast, Env* env) {
|
||||
|
||||
/* forward reference */
|
||||
MalType* regularise_parameters(list* params, MalType** more);
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
return make_error("'fn*': missing argument list");
|
||||
}
|
||||
else if (!lst->next->next) {
|
||||
return make_error("'fn*': missing function body");
|
||||
}
|
||||
|
||||
MalType* params = lst->next->data;
|
||||
list params_list = params->value.mal_list;
|
||||
|
||||
MalType* more_symbol = NULL;
|
||||
|
||||
MalType* result = regularise_parameters(¶ms_list, &more_symbol);
|
||||
if (is_error(result)) { return result; }
|
||||
|
||||
MalType* definition = lst->next->next->data;
|
||||
MalType* regular_params = make_list(params_list);
|
||||
|
||||
return make_closure(env, regular_params, definition, more_symbol);
|
||||
}
|
||||
|
||||
MalType* eval_do(MalType* ast, Env* env) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
/* handle empty 'do' */
|
||||
if (!lst->next) {
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
/* evaluate all but the last form */
|
||||
lst = lst->next;
|
||||
while (lst->next) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
/* return error early */
|
||||
if (is_error(val)) {
|
||||
return val;
|
||||
}
|
||||
lst = lst->next;
|
||||
}
|
||||
/* return the last form for TCE evaluation */
|
||||
return lst->data;
|
||||
}
|
||||
|
||||
list evaluate_list(list lst, Env* env) {
|
||||
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_vector(list lst, Env* env) {
|
||||
/* TODO: implement a real vector */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_hashmap(list lst, Env* env) {
|
||||
/* TODO: implement a real hashmap */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
/* keys are unevaluated */
|
||||
evlst = list_push(evlst, lst->data);
|
||||
lst = lst->next;
|
||||
|
||||
/* values are evaluated */
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
MalType* regularise_parameters(list* args, MalType** more_symbol) {
|
||||
|
||||
/* forward reference */
|
||||
char* symbol_fn(gptr data);
|
||||
|
||||
list regular_args = NULL;
|
||||
while (*args) {
|
||||
|
||||
MalType* val = (*args)->data;
|
||||
|
||||
if (!is_symbol(val)) {
|
||||
return make_error_fmt("non-symbol found in fn argument list '%s'", \
|
||||
pr_str(val, UNREADABLY));
|
||||
}
|
||||
|
||||
if (val->value.mal_symbol[0] == '&') {
|
||||
|
||||
/* & is found but there is no symbol */
|
||||
if (val->value.mal_symbol[1] == '\0' && !(*args)->next) {
|
||||
return make_error("missing symbol after '&' in argument list");
|
||||
}
|
||||
/* & is found and there is a single symbol after */
|
||||
else if ((val->value.mal_symbol[1] == '\0' && (*args)->next &&
|
||||
is_symbol((*args)->next->data) && !(*args)->next->next)) {
|
||||
|
||||
/* TODO: check symbol is no a duplicate of one already on the list */
|
||||
*more_symbol = (*args)->next->data;
|
||||
break;
|
||||
}
|
||||
/* & is found and there extra symbols after */
|
||||
else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) {
|
||||
return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \
|
||||
pr_str((*args)->next->data, UNREADABLY), \
|
||||
pr_str((*args)->next->next->data, UNREADABLY));
|
||||
}
|
||||
/* & is found as part of the symbol and no other symbols */
|
||||
else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) {
|
||||
*more_symbol = make_symbol((val->value.mal_symbol + 1));
|
||||
break;
|
||||
}
|
||||
/* & is found as part of the symbol but there are other symbols after */
|
||||
else if (val->value.mal_symbol[1] != '\0' && (*args)->next) {
|
||||
return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \
|
||||
pr_str(val, UNREADABLY), \
|
||||
pr_str((*args)->next->data, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
/* & is not found - add the symbol to the regular argument list */
|
||||
else {
|
||||
|
||||
if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) {
|
||||
return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY));
|
||||
}
|
||||
else {
|
||||
regular_args = list_push(regular_args, val);
|
||||
}
|
||||
}
|
||||
*args = (*args)->next;
|
||||
}
|
||||
|
||||
*args = list_reverse(regular_args);
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
char* symbol_fn(gptr data) {
|
||||
return (((MalType*)data)->value.mal_symbol);
|
||||
}
|
||||
|
||||
/* used by core functions but not EVAL as doesn't do TCE */
|
||||
MalType* apply(MalType* fn, list args) {
|
||||
|
||||
if (is_function(fn)) {
|
||||
|
||||
MalType* (*fun_ptr)(list) = fn->value.mal_function;
|
||||
return (*fun_ptr)(args);
|
||||
}
|
||||
else { /* is_closure(fn) */
|
||||
|
||||
MalClosure* c = fn->value.mal_closure;
|
||||
list params = (c->parameters)->value.mal_list;
|
||||
|
||||
long param_count = list_count(params);
|
||||
long arg_count = list_count(args);
|
||||
|
||||
if (param_count > arg_count) {
|
||||
return make_error("too few arguments supplied to function");
|
||||
}
|
||||
else if ((param_count < arg_count) && !c->more_symbol) {
|
||||
return make_error("too many arguments supplied to function");
|
||||
}
|
||||
else {
|
||||
Env* env = env_make(c->env, params, args, c->more_symbol);
|
||||
return EVAL(fn->value.mal_closure->definition, env);
|
||||
}
|
||||
}
|
||||
}
|
788
impls/c.2/step7_quote.c
Normal file
788
impls/c.2/step7_quote.c
Normal file
@ -0,0 +1,788 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <gc.h>
|
||||
|
||||
#include <editline/readline.h>
|
||||
#include <editline/history.h>
|
||||
|
||||
#include "types.h"
|
||||
#include "reader.h"
|
||||
#include "printer.h"
|
||||
#include "env.h"
|
||||
#include "core.h"
|
||||
|
||||
#define SYMBOL_DEFBANG "def!"
|
||||
#define SYMBOL_LETSTAR "let*"
|
||||
#define SYMBOL_DO "do"
|
||||
#define SYMBOL_IF "if"
|
||||
#define SYMBOL_FNSTAR "fn*"
|
||||
#define SYMBOL_QUOTE "quote"
|
||||
#define SYMBOL_QUASIQUOTE "quasiquote"
|
||||
#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand"
|
||||
#define SYMBOL_UNQUOTE "unquote"
|
||||
#define SYMBOL_SPLICE_UNQUOTE "splice-unquote"
|
||||
|
||||
#define PROMPT_STRING "user> "
|
||||
|
||||
MalType* READ(char* str) {
|
||||
|
||||
return read_str(str);
|
||||
}
|
||||
|
||||
MalType* EVAL(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
MalType* eval_ast(MalType* ast, Env* env);
|
||||
MalType* eval_defbang(MalType* ast, Env** env);
|
||||
void eval_letstar(MalType** ast, Env** env);
|
||||
void eval_if(MalType** ast, Env** env);
|
||||
MalType* eval_fnstar(MalType* ast, Env* env);
|
||||
MalType* eval_do(MalType* ast, Env* env);
|
||||
MalType* eval_quote(MalType* ast);
|
||||
MalType* eval_quasiquote(MalType* ast);
|
||||
MalType* eval_quasiquoteexpand(MalType* ast);
|
||||
|
||||
/* Use goto to jump here rather than calling eval for tail-call elimination */
|
||||
TCE_entry_point:
|
||||
|
||||
/* NULL */
|
||||
if (!ast) { return make_nil(); }
|
||||
|
||||
/* not a list */
|
||||
if (!is_list(ast)) { return eval_ast(ast, env); }
|
||||
|
||||
/* empty list */
|
||||
if (ast->value.mal_list == NULL) { return ast; }
|
||||
|
||||
/* list */
|
||||
MalType* first = (ast->value.mal_list)->data;
|
||||
char* symbol = first->value.mal_symbol;
|
||||
|
||||
if (is_symbol(first)) {
|
||||
|
||||
/* handle special symbols first */
|
||||
if (strcmp(symbol, SYMBOL_DEFBANG) == 0) {
|
||||
return eval_defbang(ast, &env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
eval_letstar(&ast, &env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_IF) == 0) {
|
||||
|
||||
/* TCE - modify ast directly and jump back to eval */
|
||||
eval_if(&ast, &env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) {
|
||||
return eval_fnstar(ast, env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_DO) == 0) {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
ast = eval_do(ast, env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_QUOTE) == 0) {
|
||||
return eval_quote(ast);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_QUASIQUOTE) == 0) {
|
||||
|
||||
ast = eval_quasiquote(ast);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
return eval_quasiquote(make_list(lst));
|
||||
}
|
||||
}
|
||||
|
||||
/* first element is not a special symbol */
|
||||
MalType* evaluated_list = eval_ast(ast, env);
|
||||
|
||||
if (is_error(evaluated_list)) { return evaluated_list; }
|
||||
|
||||
/* apply the first element of the list to the arguments */
|
||||
list evlst = evaluated_list->value.mal_list;
|
||||
MalType* func = evlst->data;
|
||||
|
||||
if (is_function(func)) {
|
||||
return (*func->value.mal_function)(evlst->next);
|
||||
}
|
||||
else if (is_closure(func)) {
|
||||
|
||||
MalClosure* closure = func->value.mal_closure;
|
||||
list params = (closure->parameters)->value.mal_list;
|
||||
|
||||
long param_count = list_count(params);
|
||||
long arg_count = list_count(evlst->next);
|
||||
|
||||
if (param_count > arg_count) {
|
||||
return make_error("too few arguments supplied to function");
|
||||
}
|
||||
else if ((param_count < arg_count) && !closure->more_symbol) {
|
||||
return make_error("too many arguments supplied to function");
|
||||
}
|
||||
else {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
env = env_make(closure->env, params, evlst->next, closure->more_symbol);
|
||||
ast = func->value.mal_closure->definition;
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return make_error_fmt("first item in list is not callable: '%s'", \
|
||||
pr_str(func, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
void PRINT(MalType* val) {
|
||||
|
||||
char* output = pr_str(val, READABLY);
|
||||
printf("%s\n", output);
|
||||
}
|
||||
|
||||
void rep(char* str, Env* env) {
|
||||
|
||||
PRINT(EVAL(READ(str), env));
|
||||
}
|
||||
|
||||
/* declare as global so it can be accessed by mal_eval */
|
||||
Env* global_env;
|
||||
|
||||
MalType* mal_eval(list args) {
|
||||
|
||||
MalType* ast = args->data;
|
||||
return EVAL(ast, global_env);
|
||||
}
|
||||
|
||||
int main(int argc, char** argv) {
|
||||
|
||||
Env* repl_env = env_make(NULL, NULL, NULL, NULL);
|
||||
global_env = repl_env;
|
||||
|
||||
ns* core = ns_make_core();
|
||||
hashmap mappings = core->mappings;
|
||||
|
||||
while (mappings) {
|
||||
char* symbol = mappings->data;
|
||||
MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data;
|
||||
|
||||
env_set_C_fn(repl_env, symbol, function);
|
||||
|
||||
/* pop symbol and function from hashmap/list */
|
||||
mappings = mappings->next->next;
|
||||
}
|
||||
|
||||
env_set_C_fn(repl_env, "eval", mal_eval);
|
||||
|
||||
/* add functions written in mal - not using rep as it prints the result */
|
||||
EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env);
|
||||
EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env);
|
||||
|
||||
|
||||
/* make command line arguments available in the environment */
|
||||
list lst = NULL;
|
||||
for (long i = 2; i < argc; i++) {
|
||||
lst = list_push(lst, make_string(argv[i]));
|
||||
}
|
||||
env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst)));
|
||||
|
||||
/* run in script mode if a filename is given */
|
||||
if (argc > 1) {
|
||||
|
||||
/* first argument on command line is filename */
|
||||
char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]);
|
||||
EVAL(READ(load_command), repl_env);
|
||||
}
|
||||
/* run in repl mode when no cmd line args */
|
||||
else {
|
||||
|
||||
/* Greeting message */
|
||||
puts("Make-a-lisp version 0.0.7\n");
|
||||
puts("Press Ctrl+d to exit\n");
|
||||
|
||||
while (1) {
|
||||
|
||||
/* print prompt and get input*/
|
||||
/* readline allocates memory for input */
|
||||
char* input = readline(PROMPT_STRING);
|
||||
|
||||
/* Check for EOF (Ctrl-D) */
|
||||
if (!input) {
|
||||
printf("\n\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* add input to history */
|
||||
add_history(input);
|
||||
|
||||
/* call Read-Eval-Print */
|
||||
rep(input, repl_env);
|
||||
|
||||
/* have to release the memory used by readline */
|
||||
free(input);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
MalType* eval_ast(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
list evaluate_list(list lst, Env* env);
|
||||
list evaluate_vector(list lst, Env* env);
|
||||
list evaluate_hashmap(list lst, Env* env);
|
||||
|
||||
if (is_symbol(ast)) {
|
||||
|
||||
MalType* symbol_value = env_get(env, ast);
|
||||
|
||||
if (symbol_value) {
|
||||
return symbol_value;
|
||||
} else {
|
||||
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
|
||||
}
|
||||
}
|
||||
else if (is_list(ast)) {
|
||||
|
||||
list result = evaluate_list(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_list(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_vector(ast)) {
|
||||
|
||||
list result = evaluate_vector(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_vector(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_hashmap(ast)) {
|
||||
|
||||
list result = evaluate_hashmap(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_hashmap(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return ast;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_defbang(MalType* ast, Env** env) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
if (!lst || !lst->next || lst->next->next) {
|
||||
return make_error_fmt("'def!': expected exactly two arguments");
|
||||
}
|
||||
|
||||
MalType* defbang_symbol = lst->data;
|
||||
|
||||
if (!is_symbol(defbang_symbol)) {
|
||||
return make_error_fmt("'def!': expected symbol for first argument");
|
||||
}
|
||||
|
||||
MalType* defbang_value = lst->next->data;
|
||||
MalType* result = EVAL(defbang_value, *env);
|
||||
|
||||
if (!is_error(result)){
|
||||
*env = env_set(*env, defbang_symbol, result);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
void eval_letstar(MalType** ast, Env** env) {
|
||||
|
||||
list lst = (*ast)->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
*ast = make_error("'let*': missing bindings list");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* bindings = lst->next->data;
|
||||
MalType* forms = lst->next->next ? lst->next->next->data : make_nil();
|
||||
|
||||
if (!is_sequential(bindings)) {
|
||||
*ast = make_error("'let*': first argument is not list or vector");
|
||||
return;
|
||||
}
|
||||
|
||||
list bindings_list = bindings->value.mal_list;
|
||||
if (list_count(bindings_list) % 2 == 1) {
|
||||
*ast = make_error("'let*': expected an even number of binding pairs");
|
||||
return;
|
||||
}
|
||||
|
||||
Env* letstar_env = env_make(*env, NULL, NULL, NULL);
|
||||
|
||||
/* evaluate the bindings */
|
||||
while(bindings_list) {
|
||||
|
||||
MalType* symbol = bindings_list->data;
|
||||
MalType* value = EVAL(bindings_list->next->data, letstar_env);
|
||||
|
||||
/* early return from error */
|
||||
if (is_error(value)) {
|
||||
*ast = value;
|
||||
return;
|
||||
}
|
||||
|
||||
env_set(letstar_env, symbol, value);
|
||||
bindings_list = bindings_list->next->next;
|
||||
}
|
||||
|
||||
*env = letstar_env;
|
||||
*ast = forms;
|
||||
return;
|
||||
}
|
||||
|
||||
void eval_if(MalType** ast, Env** env) {
|
||||
|
||||
list lst = (*ast)->value.mal_list;
|
||||
|
||||
if (!lst->next || !lst->next->next) {
|
||||
*ast = make_error("'if': too few arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
if (lst->next->next->next && lst->next->next->next->next) {
|
||||
*ast = make_error("'if': too many arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* condition = EVAL(lst->next->data, *env);
|
||||
|
||||
if (is_error(condition)) {
|
||||
*ast = condition;
|
||||
return;
|
||||
}
|
||||
|
||||
if (is_false(condition) || is_nil(condition)) {
|
||||
|
||||
/* check whether false branch is present */
|
||||
if (lst->next->next->next) {
|
||||
*ast = lst->next->next->next->data;
|
||||
return;
|
||||
}
|
||||
else {
|
||||
*ast = make_nil();
|
||||
return;
|
||||
}
|
||||
|
||||
} else {
|
||||
*ast = lst->next->next->data;
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_fnstar(MalType* ast, Env* env) {
|
||||
|
||||
/* forward reference */
|
||||
MalType* regularise_parameters(list* params, MalType** more);
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
return make_error("'fn*': missing argument list");
|
||||
}
|
||||
else if (!lst->next->next) {
|
||||
return make_error("'fn*': missing function body");
|
||||
}
|
||||
|
||||
MalType* params = lst->next->data;
|
||||
list params_list = params->value.mal_list;
|
||||
|
||||
MalType* more_symbol = NULL;
|
||||
|
||||
MalType* result = regularise_parameters(¶ms_list, &more_symbol);
|
||||
if (is_error(result)) { return result; }
|
||||
|
||||
MalType* definition = lst->next->next->data;
|
||||
MalType* regular_params = make_list(params_list);
|
||||
|
||||
return make_closure(env, regular_params, definition, more_symbol);
|
||||
}
|
||||
|
||||
MalType* eval_do(MalType* ast, Env* env) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
/* handle empty 'do' */
|
||||
if (!lst->next) {
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
/* evaluate all but the last form */
|
||||
lst = lst->next;
|
||||
while (lst->next) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
/* return error early */
|
||||
if (is_error(val)) {
|
||||
return val;
|
||||
}
|
||||
lst = lst->next;
|
||||
}
|
||||
/* return the last form for TCE evaluation */
|
||||
return lst->data;
|
||||
}
|
||||
|
||||
MalType* eval_quote(MalType* ast) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
if (!lst) {
|
||||
return make_nil();
|
||||
}
|
||||
else if (lst->next) {
|
||||
return make_error("'quote': expected exactly one argument");
|
||||
}
|
||||
else {
|
||||
return lst->data;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_quasiquote(MalType* ast) {
|
||||
|
||||
/* forward reference */
|
||||
MalType* quasiquote(MalType* ast);
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
/* no arguments (quasiquote) */
|
||||
if (!lst->next) {
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
/* too many arguments */
|
||||
else if (lst->next->next) {
|
||||
return make_error("'quasiquote': expected exactly one argument");
|
||||
}
|
||||
return quasiquote(lst->next->data);
|
||||
}
|
||||
|
||||
MalType* quasiquote(MalType* ast) {
|
||||
|
||||
/* forward references */
|
||||
MalType* quasiquote_list(MalType* ast);
|
||||
MalType* quasiquote_vector(MalType* ast);
|
||||
|
||||
/* argument to quasiquote is self-evaluating: (quasiquote val)
|
||||
=> val */
|
||||
if (is_self_evaluating(ast)) {
|
||||
return ast;
|
||||
}
|
||||
|
||||
/* argument to quasiquote is a vector: (quasiquote [first rest]) */
|
||||
else if (is_vector(ast)) {
|
||||
|
||||
return quasiquote_vector(ast);
|
||||
}
|
||||
|
||||
/* argument to quasiquote is a list: (quasiquote (first rest)) */
|
||||
else if (is_list(ast)){
|
||||
|
||||
return quasiquote_list(ast);
|
||||
}
|
||||
/* argument to quasiquote is not self-evaluating and isn't sequential: (quasiquote val)
|
||||
=> (quote val) */
|
||||
else {
|
||||
|
||||
list lst = list_make(ast);
|
||||
lst = list_push(lst, make_symbol("quote"));
|
||||
return make_list(lst);
|
||||
}
|
||||
}
|
||||
|
||||
MalType* quasiquote_vector(MalType* ast) {
|
||||
|
||||
/* forward references */
|
||||
MalType* quasiquote_list(MalType* ast);
|
||||
|
||||
list args = ast->value.mal_list;
|
||||
|
||||
if (args) {
|
||||
|
||||
MalType* first = args->data;
|
||||
|
||||
/* if first element is unquote return quoted */
|
||||
if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0) {
|
||||
|
||||
list lst = list_make(ast);
|
||||
lst = list_push(lst, make_symbol("quote"));
|
||||
|
||||
return make_list(lst);
|
||||
}
|
||||
}
|
||||
|
||||
/* otherwise process like a list */
|
||||
|
||||
list lst = list_make(make_symbol("vec"));
|
||||
|
||||
MalType* result = quasiquote_list(ast);
|
||||
|
||||
if (is_error(result)) {
|
||||
return result;
|
||||
} else {
|
||||
lst = list_push(lst, result);
|
||||
}
|
||||
|
||||
lst = list_reverse(lst);
|
||||
return make_list(lst);
|
||||
}
|
||||
|
||||
MalType* quasiquote_list(MalType* ast) {
|
||||
|
||||
list args = ast->value.mal_list;
|
||||
|
||||
/* handle empty list: (quasiquote ())
|
||||
=> () */
|
||||
if (!args) {
|
||||
return make_list(NULL);
|
||||
}
|
||||
|
||||
MalType* first = args->data;
|
||||
|
||||
/* handle unquote: (quasiquote (unquote second))
|
||||
=> second */
|
||||
if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0 && args->next) {
|
||||
|
||||
if (args->next->next) {
|
||||
return make_error("'quasiquote': unquote expected exactly one argument");
|
||||
}
|
||||
else {
|
||||
return args->next->data;
|
||||
}
|
||||
}
|
||||
|
||||
/* handle splice-unquote: (quasiquote ((splice-unquote first-second) rest))
|
||||
=> (concat first-second (quasiquote rest)) */
|
||||
else if (is_list(first) &&
|
||||
first->value.mal_list != NULL &&
|
||||
is_symbol(first->value.mal_list->data) &&
|
||||
strcmp(((MalType*)first->value.mal_list->data)->value.mal_symbol, SYMBOL_SPLICE_UNQUOTE) == 0) {
|
||||
|
||||
if (!first->value.mal_list->next) {
|
||||
return make_error("'quasiquote': splice-unquote expected exactly one argument");
|
||||
}
|
||||
|
||||
MalType* first_second = first->value.mal_list->next->data;
|
||||
list lst = list_make(make_symbol("concat"));
|
||||
lst = list_push(lst, first_second);
|
||||
|
||||
MalType* rest = quasiquote(make_list(args->next));
|
||||
if (is_error(rest)) {
|
||||
return rest;
|
||||
}
|
||||
|
||||
lst = list_push(lst, rest);
|
||||
lst = list_reverse(lst);
|
||||
|
||||
return make_list(lst);
|
||||
}
|
||||
/* handle all other lists recursively: (quasiquote (first rest))
|
||||
=> (cons (quasiquote first) (quasiquote rest)) */
|
||||
else {
|
||||
|
||||
list lst = list_make(make_symbol("cons"));
|
||||
|
||||
MalType* first = quasiquote(args->data);
|
||||
if (is_error(first)) {
|
||||
return first;
|
||||
} else {
|
||||
lst = list_push(lst, first);
|
||||
}
|
||||
|
||||
MalType* rest = quasiquote(make_list(args->next));
|
||||
if (is_error(rest)) {
|
||||
return rest;
|
||||
} else {
|
||||
lst = list_push(lst, rest);
|
||||
}
|
||||
|
||||
lst = list_reverse(lst);
|
||||
return make_list(lst);
|
||||
}
|
||||
}
|
||||
|
||||
list evaluate_list(list lst, Env* env) {
|
||||
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_vector(list lst, Env* env) {
|
||||
/* TODO: implement a real vector */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_hashmap(list lst, Env* env) {
|
||||
/* TODO: implement a real hashmap */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
/* keys are unevaluated */
|
||||
evlst = list_push(evlst, lst->data);
|
||||
lst = lst->next;
|
||||
|
||||
/* values are evaluated */
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
MalType* regularise_parameters(list* args, MalType** more_symbol) {
|
||||
|
||||
/* forward reference */
|
||||
char* symbol_fn(gptr data);
|
||||
|
||||
list regular_args = NULL;
|
||||
while (*args) {
|
||||
|
||||
MalType* val = (*args)->data;
|
||||
|
||||
if (!is_symbol(val)) {
|
||||
return make_error_fmt("non-symbol found in fn argument list '%s'", \
|
||||
pr_str(val, UNREADABLY));
|
||||
}
|
||||
|
||||
if (val->value.mal_symbol[0] == '&') {
|
||||
|
||||
/* & is found but there is no symbol */
|
||||
if (val->value.mal_symbol[1] == '\0' && !(*args)->next) {
|
||||
return make_error("missing symbol after '&' in argument list");
|
||||
}
|
||||
/* & is found and there is a single symbol after */
|
||||
else if ((val->value.mal_symbol[1] == '\0' && (*args)->next &&
|
||||
is_symbol((*args)->next->data) && !(*args)->next->next)) {
|
||||
|
||||
/* TODO: check symbol is no a duplicate of one already on the list */
|
||||
*more_symbol = (*args)->next->data;
|
||||
break;
|
||||
}
|
||||
/* & is found and there extra symbols after */
|
||||
else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) {
|
||||
return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \
|
||||
pr_str((*args)->next->data, UNREADABLY), \
|
||||
pr_str((*args)->next->next->data, UNREADABLY));
|
||||
}
|
||||
/* & is found as part of the symbol and no other symbols */
|
||||
else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) {
|
||||
*more_symbol = make_symbol((val->value.mal_symbol + 1));
|
||||
break;
|
||||
}
|
||||
/* & is found as part of the symbol but there are other symbols after */
|
||||
else if (val->value.mal_symbol[1] != '\0' && (*args)->next) {
|
||||
return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \
|
||||
pr_str(val, UNREADABLY), \
|
||||
pr_str((*args)->next->data, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
/* & is not found - add the symbol to the regular argument list */
|
||||
else {
|
||||
|
||||
if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) {
|
||||
return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY));
|
||||
}
|
||||
else {
|
||||
regular_args = list_push(regular_args, val);
|
||||
}
|
||||
}
|
||||
*args = (*args)->next;
|
||||
}
|
||||
|
||||
*args = list_reverse(regular_args);
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
char* symbol_fn(gptr data) {
|
||||
return (((MalType*)data)->value.mal_symbol);
|
||||
}
|
||||
|
||||
/* used by core functions but not EVAL as doesn't do TCE */
|
||||
MalType* apply(MalType* fn, list args) {
|
||||
|
||||
if (is_function(fn)) {
|
||||
|
||||
MalType* (*fun_ptr)(list) = fn->value.mal_function;
|
||||
return (*fun_ptr)(args);
|
||||
}
|
||||
else { /* is_closure(fn) */
|
||||
|
||||
MalClosure* c = fn->value.mal_closure;
|
||||
list params = (c->parameters)->value.mal_list;
|
||||
|
||||
long param_count = list_count(params);
|
||||
long arg_count = list_count(args);
|
||||
|
||||
if (param_count > arg_count) {
|
||||
return make_error("too few arguments supplied to function");
|
||||
}
|
||||
else if ((param_count < arg_count) && !c->more_symbol) {
|
||||
return make_error("too many arguments supplied to function");
|
||||
}
|
||||
else {
|
||||
Env* env = env_make(c->env, params, args, c->more_symbol);
|
||||
return EVAL(fn->value.mal_closure->definition, env);
|
||||
}
|
||||
}
|
||||
}
|
897
impls/c.2/step8_macros.c
Normal file
897
impls/c.2/step8_macros.c
Normal file
@ -0,0 +1,897 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <gc.h>
|
||||
|
||||
#include <editline/readline.h>
|
||||
#include <editline/history.h>
|
||||
|
||||
#include "types.h"
|
||||
#include "reader.h"
|
||||
#include "printer.h"
|
||||
#include "env.h"
|
||||
#include "core.h"
|
||||
|
||||
#define SYMBOL_DEFBANG "def!"
|
||||
#define SYMBOL_LETSTAR "let*"
|
||||
#define SYMBOL_DO "do"
|
||||
#define SYMBOL_IF "if"
|
||||
#define SYMBOL_FNSTAR "fn*"
|
||||
#define SYMBOL_QUOTE "quote"
|
||||
#define SYMBOL_QUASIQUOTE "quasiquote"
|
||||
#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand"
|
||||
#define SYMBOL_UNQUOTE "unquote"
|
||||
#define SYMBOL_SPLICE_UNQUOTE "splice-unquote"
|
||||
#define SYMBOL_DEFMACROBANG "defmacro!"
|
||||
#define SYMBOL_MACROEXPAND "macroexpand"
|
||||
|
||||
#define PROMPT_STRING "user> "
|
||||
|
||||
MalType* READ(char* str) {
|
||||
|
||||
return read_str(str);
|
||||
}
|
||||
|
||||
MalType* EVAL(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
MalType* eval_ast(MalType* ast, Env* env);
|
||||
MalType* eval_defbang(MalType* ast, Env** env);
|
||||
void eval_letstar(MalType** ast, Env** env);
|
||||
void eval_if(MalType** ast, Env** env);
|
||||
MalType* eval_fnstar(MalType* ast, Env* env);
|
||||
MalType* eval_do(MalType* ast, Env* env);
|
||||
MalType* eval_quote(MalType* ast);
|
||||
MalType* eval_quasiquote(MalType* ast);
|
||||
MalType* eval_quasiquoteexpand(MalType* ast);
|
||||
MalType* eval_defmacrobang(MalType*, Env** env);
|
||||
MalType* eval_macroexpand(MalType* ast, Env* env);
|
||||
MalType* macroexpand(MalType* ast, Env* env);
|
||||
|
||||
/* Use goto to jump here rather than calling eval for tail-call elimination */
|
||||
TCE_entry_point:
|
||||
|
||||
/* NULL */
|
||||
if (!ast) { return make_nil(); }
|
||||
|
||||
/* macroexpansion */
|
||||
ast = macroexpand(ast, env);
|
||||
if (is_error(ast)) { return ast; }
|
||||
|
||||
/* not a list */
|
||||
if (!is_list(ast)) { return eval_ast(ast, env); }
|
||||
|
||||
/* empty list */
|
||||
if (ast->value.mal_list == NULL) { return ast; }
|
||||
|
||||
/* list */
|
||||
MalType* first = (ast->value.mal_list)->data;
|
||||
char* symbol = first->value.mal_symbol;
|
||||
|
||||
if (is_symbol(first)) {
|
||||
|
||||
/* handle special symbols first */
|
||||
if (strcmp(symbol, SYMBOL_DEFBANG) == 0) {
|
||||
return eval_defbang(ast, &env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
eval_letstar(&ast, &env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_IF) == 0) {
|
||||
|
||||
/* TCE - modify ast directly and jump back to eval */
|
||||
eval_if(&ast, &env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) {
|
||||
return eval_fnstar(ast, env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_DO) == 0) {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
ast = eval_do(ast, env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_QUOTE) == 0) {
|
||||
return eval_quote(ast);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_QUASIQUOTE) == 0) {
|
||||
|
||||
ast = eval_quasiquote(ast);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
return eval_quasiquote(make_list(lst));
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_DEFMACROBANG) == 0) {
|
||||
return eval_defmacrobang(ast, &env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_MACROEXPAND) == 0) {
|
||||
return eval_macroexpand(ast, env);
|
||||
}
|
||||
}
|
||||
|
||||
/* first element is not a special symbol */
|
||||
MalType* evaluated_list = eval_ast(ast, env);
|
||||
|
||||
if (is_error(evaluated_list)) { return evaluated_list; }
|
||||
|
||||
/* apply the first element of the list to the arguments */
|
||||
list evlst = evaluated_list->value.mal_list;
|
||||
MalType* func = evlst->data;
|
||||
|
||||
if (is_function(func)) {
|
||||
return (*func->value.mal_function)(evlst->next);
|
||||
}
|
||||
else if (is_closure(func)) {
|
||||
|
||||
MalClosure* closure = func->value.mal_closure;
|
||||
list params = (closure->parameters)->value.mal_list;
|
||||
|
||||
long param_count = list_count(params);
|
||||
long arg_count = list_count(evlst->next);
|
||||
|
||||
if (param_count > arg_count) {
|
||||
return make_error("too few arguments supplied to function");
|
||||
}
|
||||
else if ((param_count < arg_count) && !closure->more_symbol) {
|
||||
return make_error("too many arguments supplied to function");
|
||||
}
|
||||
else {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
env = env_make(closure->env, params, evlst->next, closure->more_symbol);
|
||||
ast = func->value.mal_closure->definition;
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return make_error_fmt("first item in list is not callable: '%s'", \
|
||||
pr_str(func, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
void PRINT(MalType* val) {
|
||||
|
||||
char* output = pr_str(val, READABLY);
|
||||
printf("%s\n", output);
|
||||
}
|
||||
|
||||
void rep(char* str, Env* env) {
|
||||
|
||||
PRINT(EVAL(READ(str), env));
|
||||
}
|
||||
|
||||
/* declare as global so it can be accessed by mal_eval */
|
||||
Env* global_env;
|
||||
|
||||
MalType* mal_eval(list args) {
|
||||
|
||||
MalType* ast = args->data;
|
||||
return EVAL(ast, global_env);
|
||||
}
|
||||
|
||||
int main(int argc, char** argv) {
|
||||
|
||||
Env* repl_env = env_make(NULL, NULL, NULL, NULL);
|
||||
global_env = repl_env;
|
||||
|
||||
ns* core = ns_make_core();
|
||||
hashmap mappings = core->mappings;
|
||||
|
||||
while (mappings) {
|
||||
char* symbol = mappings->data;
|
||||
MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data;
|
||||
|
||||
env_set_C_fn(repl_env, symbol, function);
|
||||
|
||||
/* pop symbol and function from hashmap/list */
|
||||
mappings = mappings->next->next;
|
||||
}
|
||||
|
||||
env_set_C_fn(repl_env, "eval", mal_eval);
|
||||
|
||||
/* add functions written in mal - not using rep as it prints the result */
|
||||
EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env);
|
||||
EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env);
|
||||
EVAL(READ("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))"), repl_env);
|
||||
|
||||
/* make command line arguments available in the environment */
|
||||
list lst = NULL;
|
||||
for (long i = 2; i < argc; i++) {
|
||||
lst = list_push(lst, make_string(argv[i]));
|
||||
}
|
||||
env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst)));
|
||||
|
||||
/* run in script mode if a filename is given */
|
||||
if (argc > 1) {
|
||||
|
||||
/* first argument on command line is filename */
|
||||
char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]);
|
||||
EVAL(READ(load_command), repl_env);
|
||||
}
|
||||
/* run in repl mode when no cmd line args */
|
||||
else {
|
||||
|
||||
/* Greeting message */
|
||||
puts("Make-a-lisp version 0.0.8\n");
|
||||
puts("Press Ctrl+d to exit\n");
|
||||
|
||||
while (1) {
|
||||
|
||||
/* print prompt and get input*/
|
||||
/* readline allocates memory for input */
|
||||
char* input = readline(PROMPT_STRING);
|
||||
|
||||
/* Check for EOF (Ctrl-D) */
|
||||
if (!input) {
|
||||
printf("\n\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* add input to history */
|
||||
add_history(input);
|
||||
|
||||
/* call Read-Eval-Print */
|
||||
rep(input, repl_env);
|
||||
|
||||
/* have to release the memory used by readline */
|
||||
free(input);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
MalType* eval_ast(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
list evaluate_list(list lst, Env* env);
|
||||
list evaluate_vector(list lst, Env* env);
|
||||
list evaluate_hashmap(list lst, Env* env);
|
||||
|
||||
if (is_symbol(ast)) {
|
||||
|
||||
MalType* symbol_value = env_get(env, ast);
|
||||
|
||||
if (symbol_value) {
|
||||
return symbol_value;
|
||||
} else {
|
||||
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
|
||||
}
|
||||
}
|
||||
else if (is_list(ast)) {
|
||||
|
||||
list result = evaluate_list(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_list(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_vector(ast)) {
|
||||
|
||||
list result = evaluate_vector(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_vector(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_hashmap(ast)) {
|
||||
|
||||
list result = evaluate_hashmap(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_hashmap(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return ast;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_defbang(MalType* ast, Env** env) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
if (!lst || !lst->next || lst->next->next) {
|
||||
return make_error_fmt("'def!': expected exactly two arguments");
|
||||
}
|
||||
|
||||
MalType* defbang_symbol = lst->data;
|
||||
|
||||
if (!is_symbol(defbang_symbol)) {
|
||||
return make_error_fmt("'def!': expected symbol for first argument");
|
||||
}
|
||||
|
||||
MalType* defbang_value = lst->next->data;
|
||||
MalType* result = EVAL(defbang_value, *env);
|
||||
|
||||
if (!is_error(result)){
|
||||
*env = env_set(*env, defbang_symbol, result);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
void eval_letstar(MalType** ast, Env** env) {
|
||||
|
||||
list lst = (*ast)->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
*ast = make_error("'let*': missing bindings list");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* bindings = lst->next->data;
|
||||
MalType* forms = lst->next->next ? lst->next->next->data : make_nil();
|
||||
|
||||
if (!is_sequential(bindings)) {
|
||||
*ast = make_error("'let*': first argument is not list or vector");
|
||||
return;
|
||||
}
|
||||
|
||||
list bindings_list = bindings->value.mal_list;
|
||||
if (list_count(bindings_list) % 2 == 1) {
|
||||
*ast = make_error("'let*': expected an even number of binding pairs");
|
||||
return;
|
||||
}
|
||||
|
||||
Env* letstar_env = env_make(*env, NULL, NULL, NULL);
|
||||
|
||||
/* evaluate the bindings */
|
||||
while(bindings_list) {
|
||||
|
||||
MalType* symbol = bindings_list->data;
|
||||
MalType* value = EVAL(bindings_list->next->data, letstar_env);
|
||||
|
||||
/* early return from error */
|
||||
if (is_error(value)) {
|
||||
*ast = value;
|
||||
return;
|
||||
}
|
||||
|
||||
env_set(letstar_env, symbol, value);
|
||||
bindings_list = bindings_list->next->next;
|
||||
}
|
||||
|
||||
*env = letstar_env;
|
||||
*ast = forms;
|
||||
return;
|
||||
}
|
||||
|
||||
void eval_if(MalType** ast, Env** env) {
|
||||
|
||||
list lst = (*ast)->value.mal_list;
|
||||
|
||||
if (!lst->next || !lst->next->next) {
|
||||
*ast = make_error("'if': too few arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
if (lst->next->next->next && lst->next->next->next->next) {
|
||||
*ast = make_error("'if': too many arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* condition = EVAL(lst->next->data, *env);
|
||||
|
||||
if (is_error(condition)) {
|
||||
*ast = condition;
|
||||
return;
|
||||
}
|
||||
|
||||
if (is_false(condition) || is_nil(condition)) {
|
||||
|
||||
/* check whether false branch is present */
|
||||
if (lst->next->next->next) {
|
||||
*ast = lst->next->next->next->data;
|
||||
return;
|
||||
}
|
||||
else {
|
||||
*ast = make_nil();
|
||||
return;
|
||||
}
|
||||
|
||||
} else {
|
||||
*ast = lst->next->next->data;
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_fnstar(MalType* ast, Env* env) {
|
||||
|
||||
/* forward reference */
|
||||
MalType* regularise_parameters(list* params, MalType** more);
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
return make_error("'fn*': missing argument list");
|
||||
}
|
||||
else if (!lst->next->next) {
|
||||
return make_error("'fn*': missing function body");
|
||||
}
|
||||
|
||||
MalType* params = lst->next->data;
|
||||
list params_list = params->value.mal_list;
|
||||
|
||||
MalType* more_symbol = NULL;
|
||||
|
||||
MalType* result = regularise_parameters(¶ms_list, &more_symbol);
|
||||
if (is_error(result)) { return result; }
|
||||
|
||||
MalType* definition = lst->next->next->data;
|
||||
MalType* regular_params = make_list(params_list);
|
||||
|
||||
return make_closure(env, regular_params, definition, more_symbol);
|
||||
}
|
||||
|
||||
MalType* eval_do(MalType* ast, Env* env) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
/* handle empty 'do' */
|
||||
if (!lst->next) {
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
/* evaluate all but the last form */
|
||||
lst = lst->next;
|
||||
while (lst->next) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
/* return error early */
|
||||
if (is_error(val)) {
|
||||
return val;
|
||||
}
|
||||
lst = lst->next;
|
||||
}
|
||||
/* return the last form for TCE evaluation */
|
||||
return lst->data;
|
||||
}
|
||||
|
||||
MalType* eval_quote(MalType* ast) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
if (!lst) {
|
||||
return make_nil();
|
||||
}
|
||||
else if (lst->next) {
|
||||
return make_error("'quote': expected exactly one argument");
|
||||
}
|
||||
else {
|
||||
return lst->data;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_quasiquote(MalType* ast) {
|
||||
|
||||
/* forward reference */
|
||||
MalType* quasiquote(MalType* ast);
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
/* no arguments (quasiquote) */
|
||||
if (!lst->next) {
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
/* too many arguments */
|
||||
else if (lst->next->next) {
|
||||
return make_error("'quasiquote': expected exactly one argument");
|
||||
}
|
||||
return quasiquote(lst->next->data);
|
||||
}
|
||||
|
||||
MalType* quasiquote(MalType* ast) {
|
||||
|
||||
/* forward references */
|
||||
MalType* quasiquote_list(MalType* ast);
|
||||
MalType* quasiquote_vector(MalType* ast);
|
||||
|
||||
/* argument to quasiquote is self-evaluating: (quasiquote val)
|
||||
=> val */
|
||||
if (is_self_evaluating(ast)) {
|
||||
return ast;
|
||||
}
|
||||
|
||||
/* argument to quasiquote is a vector: (quasiquote [first rest]) */
|
||||
else if (is_vector(ast)) {
|
||||
|
||||
return quasiquote_vector(ast);
|
||||
}
|
||||
|
||||
/* argument to quasiquote is a list: (quasiquote (first rest)) */
|
||||
else if (is_list(ast)){
|
||||
|
||||
return quasiquote_list(ast);
|
||||
}
|
||||
/* argument to quasiquote is not self-evaluating and isn't sequential: (quasiquote val)
|
||||
=> (quote val) */
|
||||
else {
|
||||
|
||||
list lst = list_make(ast);
|
||||
lst = list_push(lst, make_symbol("quote"));
|
||||
return make_list(lst);
|
||||
}
|
||||
}
|
||||
|
||||
MalType* quasiquote_vector(MalType* ast) {
|
||||
|
||||
/* forward references */
|
||||
MalType* quasiquote_list(MalType* ast);
|
||||
|
||||
list args = ast->value.mal_list;
|
||||
|
||||
if (args) {
|
||||
|
||||
MalType* first = args->data;
|
||||
|
||||
/* if first element is unquote return quoted */
|
||||
if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0) {
|
||||
|
||||
list lst = list_make(ast);
|
||||
lst = list_push(lst, make_symbol("quote"));
|
||||
|
||||
return make_list(lst);
|
||||
}
|
||||
}
|
||||
|
||||
/* otherwise process like a list */
|
||||
|
||||
list lst = list_make(make_symbol("vec"));
|
||||
|
||||
MalType* result = quasiquote_list(ast);
|
||||
|
||||
if (is_error(result)) {
|
||||
return result;
|
||||
} else {
|
||||
lst = list_push(lst, result);
|
||||
}
|
||||
|
||||
lst = list_reverse(lst);
|
||||
return make_list(lst);
|
||||
}
|
||||
|
||||
MalType* quasiquote_list(MalType* ast) {
|
||||
|
||||
list args = ast->value.mal_list;
|
||||
|
||||
/* handle empty list: (quasiquote ())
|
||||
=> () */
|
||||
if (!args) {
|
||||
return make_list(NULL);
|
||||
}
|
||||
|
||||
MalType* first = args->data;
|
||||
|
||||
/* handle unquote: (quasiquote (unquote second))
|
||||
=> second */
|
||||
if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0 && args->next) {
|
||||
|
||||
if (args->next->next) {
|
||||
return make_error("'quasiquote': unquote expected exactly one argument");
|
||||
}
|
||||
else {
|
||||
return args->next->data;
|
||||
}
|
||||
}
|
||||
|
||||
/* handle splice-unquote: (quasiquote ((splice-unquote first-second) rest))
|
||||
=> (concat first-second (quasiquote rest)) */
|
||||
else if (is_list(first) &&
|
||||
first->value.mal_list != NULL &&
|
||||
is_symbol(first->value.mal_list->data) &&
|
||||
strcmp(((MalType*)first->value.mal_list->data)->value.mal_symbol, SYMBOL_SPLICE_UNQUOTE) == 0) {
|
||||
|
||||
if (!first->value.mal_list->next) {
|
||||
return make_error("'quasiquote': splice-unquote expected exactly one argument");
|
||||
}
|
||||
|
||||
MalType* first_second = first->value.mal_list->next->data;
|
||||
list lst = list_make(make_symbol("concat"));
|
||||
lst = list_push(lst, first_second);
|
||||
|
||||
MalType* rest = quasiquote(make_list(args->next));
|
||||
if (is_error(rest)) {
|
||||
return rest;
|
||||
}
|
||||
|
||||
lst = list_push(lst, rest);
|
||||
lst = list_reverse(lst);
|
||||
|
||||
return make_list(lst);
|
||||
}
|
||||
/* handle all other lists recursively: (quasiquote (first rest))
|
||||
=> (cons (quasiquote first) (quasiquote rest)) */
|
||||
else {
|
||||
|
||||
list lst = list_make(make_symbol("cons"));
|
||||
|
||||
MalType* first = quasiquote(args->data);
|
||||
if (is_error(first)) {
|
||||
return first;
|
||||
} else {
|
||||
lst = list_push(lst, first);
|
||||
}
|
||||
|
||||
MalType* rest = quasiquote(make_list(args->next));
|
||||
if (is_error(rest)) {
|
||||
return rest;
|
||||
} else {
|
||||
lst = list_push(lst, rest);
|
||||
}
|
||||
|
||||
lst = list_reverse(lst);
|
||||
return make_list(lst);
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_defmacrobang(MalType* ast, Env** env) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
if (!lst || !lst->next || lst->next->next) {
|
||||
return make_error_fmt("'defmacro!': expected exactly two arguments");
|
||||
}
|
||||
|
||||
MalType* defbang_symbol = lst->data;
|
||||
|
||||
if (!is_symbol(defbang_symbol)) {
|
||||
return make_error_fmt("'defmacro!': expected symbol for first argument");
|
||||
}
|
||||
|
||||
MalType* defbang_value = lst->next->data;
|
||||
MalType* result = EVAL(defbang_value, *env);
|
||||
|
||||
if (!is_error(result)) {
|
||||
result = copy_type(result);
|
||||
result->is_macro = 1;
|
||||
*env = env_set(*env, defbang_symbol, result);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
MalType* eval_macroexpand(MalType* ast, Env* env) {
|
||||
|
||||
/* forward reference */
|
||||
MalType* macroexpand(MalType* ast, Env* env);
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
return make_nil();
|
||||
}
|
||||
else if (lst->next->next) {
|
||||
return make_error("'macroexpand': expected exactly one argument");
|
||||
}
|
||||
else {
|
||||
return macroexpand(lst->next->data, env);
|
||||
}
|
||||
}
|
||||
|
||||
MalType* macroexpand(MalType* ast, Env* env) {
|
||||
|
||||
/* forward reference */
|
||||
int is_macro_call(MalType* ast, Env* env);
|
||||
|
||||
while(is_macro_call(ast, env)) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
MalType* macro_fn = env_get(env, lst->data);
|
||||
MalClosure* cls = macro_fn->value.mal_closure;
|
||||
MalType* more_symbol = cls->more_symbol;
|
||||
|
||||
list params_list = (cls->parameters)->value.mal_list;
|
||||
list args_list = lst->next;
|
||||
|
||||
env = env_make(cls->env, params_list, args_list, more_symbol);
|
||||
ast = EVAL(cls->definition, env);
|
||||
}
|
||||
return ast;
|
||||
}
|
||||
|
||||
list evaluate_list(list lst, Env* env) {
|
||||
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_vector(list lst, Env* env) {
|
||||
/* TODO: implement a real vector */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_hashmap(list lst, Env* env) {
|
||||
/* TODO: implement a real hashmap */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
/* keys are unevaluated */
|
||||
evlst = list_push(evlst, lst->data);
|
||||
lst = lst->next;
|
||||
|
||||
/* values are evaluated */
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
MalType* regularise_parameters(list* args, MalType** more_symbol) {
|
||||
|
||||
/* forward reference */
|
||||
char* symbol_fn(gptr data);
|
||||
|
||||
list regular_args = NULL;
|
||||
while (*args) {
|
||||
|
||||
MalType* val = (*args)->data;
|
||||
|
||||
if (!is_symbol(val)) {
|
||||
return make_error_fmt("non-symbol found in fn argument list '%s'", \
|
||||
pr_str(val, UNREADABLY));
|
||||
}
|
||||
|
||||
if (val->value.mal_symbol[0] == '&') {
|
||||
|
||||
/* & is found but there is no symbol */
|
||||
if (val->value.mal_symbol[1] == '\0' && !(*args)->next) {
|
||||
return make_error("missing symbol after '&' in argument list");
|
||||
}
|
||||
/* & is found and there is a single symbol after */
|
||||
else if ((val->value.mal_symbol[1] == '\0' && (*args)->next &&
|
||||
is_symbol((*args)->next->data) && !(*args)->next->next)) {
|
||||
|
||||
/* TODO: check symbol is no a duplicate of one already on the list */
|
||||
*more_symbol = (*args)->next->data;
|
||||
break;
|
||||
}
|
||||
/* & is found and there extra symbols after */
|
||||
else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) {
|
||||
return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \
|
||||
pr_str((*args)->next->data, UNREADABLY), \
|
||||
pr_str((*args)->next->next->data, UNREADABLY));
|
||||
}
|
||||
/* & is found as part of the symbol and no other symbols */
|
||||
else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) {
|
||||
*more_symbol = make_symbol((val->value.mal_symbol + 1));
|
||||
break;
|
||||
}
|
||||
/* & is found as part of the symbol but there are other symbols after */
|
||||
else if (val->value.mal_symbol[1] != '\0' && (*args)->next) {
|
||||
return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \
|
||||
pr_str(val, UNREADABLY), \
|
||||
pr_str((*args)->next->data, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
/* & is not found - add the symbol to the regular argument list */
|
||||
else {
|
||||
|
||||
if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) {
|
||||
return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY));
|
||||
}
|
||||
else {
|
||||
regular_args = list_push(regular_args, val);
|
||||
}
|
||||
}
|
||||
*args = (*args)->next;
|
||||
}
|
||||
|
||||
*args = list_reverse(regular_args);
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
char* symbol_fn(gptr data) {
|
||||
return (((MalType*)data)->value.mal_symbol);
|
||||
}
|
||||
|
||||
/* used by core functions but not EVAL as doesn't do TCE */
|
||||
MalType* apply(MalType* fn, list args) {
|
||||
|
||||
if (is_function(fn)) {
|
||||
|
||||
MalType* (*fun_ptr)(list) = fn->value.mal_function;
|
||||
return (*fun_ptr)(args);
|
||||
}
|
||||
else { /* is_closure(fn) */
|
||||
|
||||
MalClosure* c = fn->value.mal_closure;
|
||||
list params = (c->parameters)->value.mal_list;
|
||||
|
||||
long param_count = list_count(params);
|
||||
long arg_count = list_count(args);
|
||||
|
||||
if (param_count > arg_count) {
|
||||
return make_error("too few arguments supplied to function");
|
||||
}
|
||||
else if ((param_count < arg_count) && !c->more_symbol) {
|
||||
return make_error("too many arguments supplied to function");
|
||||
}
|
||||
else {
|
||||
Env* env = env_make(c->env, params, args, c->more_symbol);
|
||||
return EVAL(fn->value.mal_closure->definition, env);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
int is_macro_call(MalType* ast, Env* env) {
|
||||
|
||||
/* not a list */
|
||||
if (!is_list(ast)) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* empty list */
|
||||
list lst = ast->value.mal_list;
|
||||
if (!lst) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* first item not a symbol */
|
||||
MalType* first = lst->data;
|
||||
if (!is_symbol(first)) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* lookup symbol */
|
||||
MalType* val = env_get(env, first);
|
||||
if (is_error(val)) {
|
||||
return 0;
|
||||
}
|
||||
else {
|
||||
return (val->is_macro);
|
||||
}
|
||||
}
|
968
impls/c.2/step9_try.c
Normal file
968
impls/c.2/step9_try.c
Normal file
@ -0,0 +1,968 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <gc.h>
|
||||
|
||||
#include <editline/readline.h>
|
||||
#include <editline/history.h>
|
||||
|
||||
#include "types.h"
|
||||
#include "reader.h"
|
||||
#include "printer.h"
|
||||
#include "env.h"
|
||||
#include "core.h"
|
||||
|
||||
#define SYMBOL_DEFBANG "def!"
|
||||
#define SYMBOL_LETSTAR "let*"
|
||||
#define SYMBOL_DO "do"
|
||||
#define SYMBOL_IF "if"
|
||||
#define SYMBOL_FNSTAR "fn*"
|
||||
#define SYMBOL_QUOTE "quote"
|
||||
#define SYMBOL_QUASIQUOTE "quasiquote"
|
||||
#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand"
|
||||
#define SYMBOL_UNQUOTE "unquote"
|
||||
#define SYMBOL_SPLICE_UNQUOTE "splice-unquote"
|
||||
#define SYMBOL_DEFMACROBANG "defmacro!"
|
||||
#define SYMBOL_MACROEXPAND "macroexpand"
|
||||
#define SYMBOL_TRYSTAR "try*"
|
||||
#define SYMBOL_CATCHSTAR "catch*"
|
||||
|
||||
#define PROMPT_STRING "user> "
|
||||
|
||||
MalType* READ(char* str) {
|
||||
|
||||
return read_str(str);
|
||||
}
|
||||
|
||||
MalType* EVAL(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
MalType* eval_ast(MalType* ast, Env* env);
|
||||
MalType* eval_defbang(MalType* ast, Env** env);
|
||||
void eval_letstar(MalType** ast, Env** env);
|
||||
void eval_if(MalType** ast, Env** env);
|
||||
MalType* eval_fnstar(MalType* ast, Env* env);
|
||||
MalType* eval_do(MalType* ast, Env* env);
|
||||
MalType* eval_quote(MalType* ast);
|
||||
MalType* eval_quasiquote(MalType* ast);
|
||||
MalType* eval_quasiquoteexpand(MalType* ast);
|
||||
MalType* eval_defmacrobang(MalType*, Env** env);
|
||||
MalType* eval_macroexpand(MalType* ast, Env* env);
|
||||
MalType* macroexpand(MalType* ast, Env* env);
|
||||
void eval_try(MalType** ast, Env** env);
|
||||
|
||||
/* Use goto to jump here rather than calling eval for tail-call elimination */
|
||||
TCE_entry_point:
|
||||
|
||||
/* NULL */
|
||||
if (!ast) { return make_nil(); }
|
||||
|
||||
/* macroexpansion */
|
||||
ast = macroexpand(ast, env);
|
||||
if (is_error(ast)) { return ast; }
|
||||
|
||||
/* not a list */
|
||||
if (!is_list(ast)) { return eval_ast(ast, env); }
|
||||
|
||||
/* empty list */
|
||||
if (ast->value.mal_list == NULL) { return ast; }
|
||||
|
||||
/* list */
|
||||
MalType* first = (ast->value.mal_list)->data;
|
||||
char* symbol = first->value.mal_symbol;
|
||||
|
||||
if (is_symbol(first)) {
|
||||
|
||||
/* handle special symbols first */
|
||||
if (strcmp(symbol, SYMBOL_DEFBANG) == 0) {
|
||||
return eval_defbang(ast, &env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
eval_letstar(&ast, &env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_IF) == 0) {
|
||||
|
||||
/* TCE - modify ast directly and jump back to eval */
|
||||
eval_if(&ast, &env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) {
|
||||
return eval_fnstar(ast, env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_DO) == 0) {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
ast = eval_do(ast, env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_QUOTE) == 0) {
|
||||
return eval_quote(ast);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_QUASIQUOTE) == 0) {
|
||||
|
||||
ast = eval_quasiquote(ast);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
return eval_quasiquote(make_list(lst));
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_DEFMACROBANG) == 0) {
|
||||
return eval_defmacrobang(ast, &env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_MACROEXPAND) == 0) {
|
||||
return eval_macroexpand(ast, env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_TRYSTAR) == 0) {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
eval_try(&ast, &env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
}
|
||||
/* first element is not a special symbol */
|
||||
MalType* evaluated_list = eval_ast(ast, env);
|
||||
|
||||
if (is_error(evaluated_list)) { return evaluated_list; }
|
||||
|
||||
/* apply the first element of the list to the arguments */
|
||||
list evlst = evaluated_list->value.mal_list;
|
||||
MalType* func = evlst->data;
|
||||
|
||||
if (is_function(func)) {
|
||||
return (*func->value.mal_function)(evlst->next);
|
||||
}
|
||||
else if (is_closure(func)) {
|
||||
|
||||
MalClosure* closure = func->value.mal_closure;
|
||||
list params = (closure->parameters)->value.mal_list;
|
||||
|
||||
long param_count = list_count(params);
|
||||
long arg_count = list_count(evlst->next);
|
||||
|
||||
if (param_count > arg_count) {
|
||||
return make_error("too few arguments supplied to function");
|
||||
}
|
||||
else if ((param_count < arg_count) && !closure->more_symbol) {
|
||||
return make_error("too many arguments supplied to function");
|
||||
}
|
||||
else {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
env = env_make(closure->env, params, evlst->next, closure->more_symbol);
|
||||
ast = func->value.mal_closure->definition;
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return make_error_fmt("first item in list is not callable: '%s'", \
|
||||
pr_str(func, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
void PRINT(MalType* val) {
|
||||
|
||||
char* output = pr_str(val, READABLY);
|
||||
printf("%s\n", output);
|
||||
}
|
||||
|
||||
void rep(char* str, Env* env) {
|
||||
|
||||
PRINT(EVAL(READ(str), env));
|
||||
}
|
||||
|
||||
/* declare as global so it can be accessed by mal_eval */
|
||||
Env* global_env;
|
||||
|
||||
MalType* mal_eval(list args) {
|
||||
|
||||
MalType* ast = args->data;
|
||||
return EVAL(ast, global_env);
|
||||
}
|
||||
|
||||
|
||||
int main(int argc, char** argv) {
|
||||
|
||||
Env* repl_env = env_make(NULL, NULL, NULL, NULL);
|
||||
global_env = repl_env;
|
||||
|
||||
ns* core = ns_make_core();
|
||||
hashmap mappings = core->mappings;
|
||||
|
||||
while (mappings) {
|
||||
char* symbol = mappings->data;
|
||||
MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data;
|
||||
|
||||
env_set_C_fn(repl_env, symbol, function);
|
||||
|
||||
/* pop symbol and function from hashmap/list */
|
||||
mappings = mappings->next->next;
|
||||
}
|
||||
|
||||
env_set_C_fn(repl_env, "eval", mal_eval);
|
||||
|
||||
/* add functions written in mal - not using rep as it prints the result */
|
||||
EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env);
|
||||
EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env);
|
||||
EVAL(READ("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))"), repl_env);
|
||||
|
||||
/* make command line arguments available in the environment */
|
||||
list lst = NULL;
|
||||
for (long i = 2; i < argc; i++) {
|
||||
lst = list_push(lst, make_string(argv[i]));
|
||||
}
|
||||
env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst)));
|
||||
|
||||
/* run in script mode if a filename is given */
|
||||
if (argc > 1) {
|
||||
|
||||
/* first argument on command line is filename */
|
||||
char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]);
|
||||
EVAL(READ(load_command), repl_env);
|
||||
}
|
||||
/* run in repl mode when no cmd line args */
|
||||
else {
|
||||
|
||||
/* Greeting message */
|
||||
puts("Make-a-lisp version 0.0.9\n");
|
||||
puts("Press Ctrl+d to exit\n");
|
||||
|
||||
while (1) {
|
||||
|
||||
/* print prompt and get input*/
|
||||
/* readline allocates memory for input */
|
||||
char* input = readline(PROMPT_STRING);
|
||||
|
||||
/* Check for EOF (Ctrl-D) */
|
||||
if (!input) {
|
||||
printf("\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* add input to history */
|
||||
add_history(input);
|
||||
|
||||
/* call Read-Eval-Print */
|
||||
rep(input, repl_env);
|
||||
|
||||
/* have to release the memory used by readline */
|
||||
free(input);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
MalType* eval_ast(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
list evaluate_list(list lst, Env* env);
|
||||
list evaluate_vector(list lst, Env* env);
|
||||
list evaluate_hashmap(list lst, Env* env);
|
||||
|
||||
if (is_symbol(ast)) {
|
||||
|
||||
MalType* symbol_value = env_get(env, ast);
|
||||
|
||||
if (symbol_value) {
|
||||
return symbol_value;
|
||||
} else {
|
||||
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
|
||||
}
|
||||
}
|
||||
else if (is_list(ast)) {
|
||||
|
||||
list result = evaluate_list(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_list(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_vector(ast)) {
|
||||
|
||||
list result = evaluate_vector(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_vector(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_hashmap(ast)) {
|
||||
|
||||
list result = evaluate_hashmap(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_hashmap(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return ast;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_defbang(MalType* ast, Env** env) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
if (!lst || !lst->next || lst->next->next) {
|
||||
return make_error_fmt("'def!': expected exactly two arguments");
|
||||
}
|
||||
|
||||
MalType* defbang_symbol = lst->data;
|
||||
|
||||
if (!is_symbol(defbang_symbol)) {
|
||||
return make_error_fmt("'def!': expected symbol for first argument");
|
||||
}
|
||||
|
||||
MalType* defbang_value = lst->next->data;
|
||||
MalType* result = EVAL(defbang_value, *env);
|
||||
|
||||
if (!is_error(result)){
|
||||
*env = env_set(*env, defbang_symbol, result);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
void eval_letstar(MalType** ast, Env** env) {
|
||||
|
||||
list lst = (*ast)->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
*ast = make_error("'let*': missing bindings list");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* bindings = lst->next->data;
|
||||
MalType* forms = lst->next->next ? lst->next->next->data : make_nil();
|
||||
|
||||
if (!is_sequential(bindings)) {
|
||||
*ast = make_error("'let*': first argument is not list or vector");
|
||||
return;
|
||||
}
|
||||
|
||||
list bindings_list = bindings->value.mal_list;
|
||||
if (list_count(bindings_list) % 2 == 1) {
|
||||
*ast = make_error("'let*': expected an even number of binding pairs");
|
||||
return;
|
||||
}
|
||||
|
||||
Env* letstar_env = env_make(*env, NULL, NULL, NULL);
|
||||
|
||||
/* evaluate the bindings */
|
||||
while(bindings_list) {
|
||||
|
||||
MalType* symbol = bindings_list->data;
|
||||
MalType* value = EVAL(bindings_list->next->data, letstar_env);
|
||||
|
||||
/* early return from error */
|
||||
if (is_error(value)) {
|
||||
*ast = value;
|
||||
return;
|
||||
}
|
||||
|
||||
env_set(letstar_env, symbol, value);
|
||||
bindings_list = bindings_list->next->next;
|
||||
}
|
||||
|
||||
*env = letstar_env;
|
||||
*ast = forms;
|
||||
return;
|
||||
}
|
||||
|
||||
void eval_if(MalType** ast, Env** env) {
|
||||
|
||||
list lst = (*ast)->value.mal_list;
|
||||
|
||||
if (!lst->next || !lst->next->next) {
|
||||
*ast = make_error("'if': too few arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
if (lst->next->next->next && lst->next->next->next->next) {
|
||||
*ast = make_error("'if': too many arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* condition = EVAL(lst->next->data, *env);
|
||||
|
||||
if (is_error(condition)) {
|
||||
*ast = condition;
|
||||
return;
|
||||
}
|
||||
|
||||
if (is_false(condition) || is_nil(condition)) {
|
||||
|
||||
/* check whether false branch is present */
|
||||
if (lst->next->next->next) {
|
||||
*ast = lst->next->next->next->data;
|
||||
return;
|
||||
}
|
||||
else {
|
||||
*ast = make_nil();
|
||||
return;
|
||||
}
|
||||
|
||||
} else {
|
||||
*ast = lst->next->next->data;
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_fnstar(MalType* ast, Env* env) {
|
||||
|
||||
/* forward reference */
|
||||
MalType* regularise_parameters(list* params, MalType** more);
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
return make_error("'fn*': missing argument list");
|
||||
}
|
||||
else if (!lst->next->next) {
|
||||
return make_error("'fn*': missing function body");
|
||||
}
|
||||
|
||||
MalType* params = lst->next->data;
|
||||
list params_list = params->value.mal_list;
|
||||
|
||||
MalType* more_symbol = NULL;
|
||||
|
||||
MalType* result = regularise_parameters(¶ms_list, &more_symbol);
|
||||
if (is_error(result)) { return result; }
|
||||
|
||||
MalType* definition = lst->next->next->data;
|
||||
MalType* regular_params = make_list(params_list);
|
||||
|
||||
return make_closure(env, regular_params, definition, more_symbol);
|
||||
}
|
||||
|
||||
MalType* eval_do(MalType* ast, Env* env) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
/* handle empty 'do' */
|
||||
if (!lst->next) {
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
/* evaluate all but the last form */
|
||||
lst = lst->next;
|
||||
while (lst->next) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
/* return error early */
|
||||
if (is_error(val)) {
|
||||
return val;
|
||||
}
|
||||
lst = lst->next;
|
||||
}
|
||||
/* return the last form for TCE evaluation */
|
||||
return lst->data;
|
||||
}
|
||||
|
||||
MalType* eval_quote(MalType* ast) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
if (!lst) {
|
||||
return make_nil();
|
||||
}
|
||||
else if (lst->next) {
|
||||
return make_error("'quote': expected exactly one argument");
|
||||
}
|
||||
else {
|
||||
return lst->data;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_quasiquote(MalType* ast) {
|
||||
|
||||
/* forward reference */
|
||||
MalType* quasiquote(MalType* ast);
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
/* no arguments (quasiquote) */
|
||||
if (!lst->next) {
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
/* too many arguments */
|
||||
else if (lst->next->next) {
|
||||
return make_error("'quasiquote': expected exactly one argument");
|
||||
}
|
||||
return quasiquote(lst->next->data);
|
||||
}
|
||||
|
||||
MalType* quasiquote(MalType* ast) {
|
||||
|
||||
/* forward references */
|
||||
MalType* quasiquote_list(MalType* ast);
|
||||
MalType* quasiquote_vector(MalType* ast);
|
||||
|
||||
/* argument to quasiquote is self-evaluating: (quasiquote val)
|
||||
=> val */
|
||||
if (is_self_evaluating(ast)) {
|
||||
return ast;
|
||||
}
|
||||
|
||||
/* argument to quasiquote is a vector: (quasiquote [first rest]) */
|
||||
else if (is_vector(ast)) {
|
||||
|
||||
return quasiquote_vector(ast);
|
||||
}
|
||||
|
||||
/* argument to quasiquote is a list: (quasiquote (first rest)) */
|
||||
else if (is_list(ast)){
|
||||
|
||||
return quasiquote_list(ast);
|
||||
}
|
||||
/* argument to quasiquote is not self-evaluating and isn't sequential: (quasiquote val)
|
||||
=> (quote val) */
|
||||
else {
|
||||
|
||||
list lst = list_make(ast);
|
||||
lst = list_push(lst, make_symbol("quote"));
|
||||
return make_list(lst);
|
||||
}
|
||||
}
|
||||
|
||||
MalType* quasiquote_vector(MalType* ast) {
|
||||
|
||||
/* forward references */
|
||||
MalType* quasiquote_list(MalType* ast);
|
||||
|
||||
list args = ast->value.mal_list;
|
||||
|
||||
if (args) {
|
||||
|
||||
MalType* first = args->data;
|
||||
|
||||
/* if first element is unquote return quoted */
|
||||
if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0) {
|
||||
|
||||
list lst = list_make(ast);
|
||||
lst = list_push(lst, make_symbol("quote"));
|
||||
|
||||
return make_list(lst);
|
||||
}
|
||||
}
|
||||
|
||||
/* otherwise process like a list */
|
||||
|
||||
list lst = list_make(make_symbol("vec"));
|
||||
|
||||
MalType* result = quasiquote_list(ast);
|
||||
|
||||
if (is_error(result)) {
|
||||
return result;
|
||||
} else {
|
||||
lst = list_push(lst, result);
|
||||
}
|
||||
|
||||
lst = list_reverse(lst);
|
||||
return make_list(lst);
|
||||
}
|
||||
|
||||
MalType* quasiquote_list(MalType* ast) {
|
||||
|
||||
list args = ast->value.mal_list;
|
||||
|
||||
/* handle empty list: (quasiquote ())
|
||||
=> () */
|
||||
if (!args) {
|
||||
return make_list(NULL);
|
||||
}
|
||||
|
||||
MalType* first = args->data;
|
||||
|
||||
/* handle unquote: (quasiquote (unquote second))
|
||||
=> second */
|
||||
if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0 && args->next) {
|
||||
|
||||
if (args->next->next) {
|
||||
return make_error("'quasiquote': unquote expected exactly one argument");
|
||||
}
|
||||
else {
|
||||
return args->next->data;
|
||||
}
|
||||
}
|
||||
|
||||
/* handle splice-unquote: (quasiquote ((splice-unquote first-second) rest))
|
||||
=> (concat first-second (quasiquote rest)) */
|
||||
else if (is_list(first) &&
|
||||
first->value.mal_list != NULL &&
|
||||
is_symbol(first->value.mal_list->data) &&
|
||||
strcmp(((MalType*)first->value.mal_list->data)->value.mal_symbol, SYMBOL_SPLICE_UNQUOTE) == 0) {
|
||||
|
||||
if (!first->value.mal_list->next) {
|
||||
return make_error("'quasiquote': splice-unquote expected exactly one argument");
|
||||
}
|
||||
|
||||
MalType* first_second = first->value.mal_list->next->data;
|
||||
list lst = list_make(make_symbol("concat"));
|
||||
lst = list_push(lst, first_second);
|
||||
|
||||
MalType* rest = quasiquote(make_list(args->next));
|
||||
if (is_error(rest)) {
|
||||
return rest;
|
||||
}
|
||||
|
||||
lst = list_push(lst, rest);
|
||||
lst = list_reverse(lst);
|
||||
|
||||
return make_list(lst);
|
||||
}
|
||||
/* handle all other lists recursively: (quasiquote (first rest))
|
||||
=> (cons (quasiquote first) (quasiquote rest)) */
|
||||
else {
|
||||
|
||||
list lst = list_make(make_symbol("cons"));
|
||||
|
||||
MalType* first = quasiquote(args->data);
|
||||
if (is_error(first)) {
|
||||
return first;
|
||||
} else {
|
||||
lst = list_push(lst, first);
|
||||
}
|
||||
|
||||
MalType* rest = quasiquote(make_list(args->next));
|
||||
if (is_error(rest)) {
|
||||
return rest;
|
||||
} else {
|
||||
lst = list_push(lst, rest);
|
||||
}
|
||||
|
||||
lst = list_reverse(lst);
|
||||
return make_list(lst);
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_defmacrobang(MalType* ast, Env** env) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
if (!lst || !lst->next || lst->next->next) {
|
||||
return make_error_fmt("'defmacro!': expected exactly two arguments");
|
||||
}
|
||||
|
||||
MalType* defbang_symbol = lst->data;
|
||||
|
||||
if (!is_symbol(defbang_symbol)) {
|
||||
return make_error_fmt("'defmacro!': expected symbol for first argument");
|
||||
}
|
||||
|
||||
MalType* defbang_value = lst->next->data;
|
||||
MalType* result = EVAL(defbang_value, *env);
|
||||
|
||||
if (!is_error(result)) {
|
||||
result = copy_type(result);
|
||||
result->is_macro = 1;
|
||||
*env = env_set(*env, defbang_symbol, result);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
MalType* eval_macroexpand(MalType* ast, Env* env) {
|
||||
|
||||
/* forward reference */
|
||||
MalType* macroexpand(MalType* ast, Env* env);
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
return make_nil();
|
||||
}
|
||||
else if (lst->next->next) {
|
||||
return make_error("'macroexpand': expected exactly one argument");
|
||||
}
|
||||
else {
|
||||
return macroexpand(lst->next->data, env);
|
||||
}
|
||||
}
|
||||
|
||||
MalType* macroexpand(MalType* ast, Env* env) {
|
||||
|
||||
/* forward reference */
|
||||
int is_macro_call(MalType* ast, Env* env);
|
||||
|
||||
while(is_macro_call(ast, env)) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
MalType* macro_fn = env_get(env, lst->data);
|
||||
MalClosure* cls = macro_fn->value.mal_closure;
|
||||
MalType* more_symbol = cls->more_symbol;
|
||||
|
||||
list params_list = (cls->parameters)->value.mal_list;
|
||||
list args_list = lst->next;
|
||||
|
||||
env = env_make(cls->env, params_list, args_list, more_symbol);
|
||||
ast = EVAL(cls->definition, env);
|
||||
}
|
||||
return ast;
|
||||
}
|
||||
|
||||
void eval_try(MalType** ast, Env** env) {
|
||||
|
||||
list lst = (*ast)->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
*ast = make_nil();
|
||||
return;
|
||||
}
|
||||
|
||||
if (lst->next->next && lst->next->next->next) {
|
||||
*ast = make_error("'try*': expected maximum of two arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* try_clause = lst->next->data;
|
||||
MalType* try_result = EVAL(try_clause, *env);
|
||||
|
||||
/* no catch* clause */
|
||||
if (!is_error(try_result) || !lst->next->next) {
|
||||
*ast = try_result;
|
||||
return;
|
||||
}
|
||||
|
||||
/* process catch* clause */
|
||||
MalType* catch_clause = lst->next->next->data;
|
||||
list catch_list = catch_clause->value.mal_list;
|
||||
|
||||
if (!catch_list) {
|
||||
*ast = make_error("'try*': catch* clause is empty");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* catch_symbol = catch_list->data;
|
||||
if (strcmp(catch_symbol->value.mal_symbol, SYMBOL_CATCHSTAR) != 0) {
|
||||
*ast = make_error("Error: catch clause is missing catch* symbol");
|
||||
return;
|
||||
}
|
||||
|
||||
if (!catch_list->next || !catch_list->next->next) {
|
||||
*ast = make_error("Error: catch* clause expected two arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
if (!is_symbol(catch_list->next->data)) {
|
||||
*ast = make_error("Error: catch* clause expected a symbol");
|
||||
return;
|
||||
}
|
||||
|
||||
/* bind the symbol to the exception */
|
||||
list symbol_list = list_make(catch_list->next->data);
|
||||
list expr_list = list_make(try_result->value.mal_error);
|
||||
|
||||
/* TODO: validate symbols and exprs match before calling env_make */
|
||||
Env* catch_env = env_make(*env, symbol_list, expr_list, NULL);
|
||||
*ast = catch_list->next->next->data;
|
||||
*env = catch_env;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
list evaluate_list(list lst, Env* env) {
|
||||
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_vector(list lst, Env* env) {
|
||||
/* TODO: implement a real vector */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_hashmap(list lst, Env* env) {
|
||||
/* TODO: implement a real hashmap */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
/* keys are unevaluated */
|
||||
evlst = list_push(evlst, lst->data);
|
||||
lst = lst->next;
|
||||
|
||||
/* values are evaluated */
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
MalType* regularise_parameters(list* args, MalType** more_symbol) {
|
||||
|
||||
/* forward reference */
|
||||
char* symbol_fn(gptr data);
|
||||
|
||||
list regular_args = NULL;
|
||||
while (*args) {
|
||||
|
||||
MalType* val = (*args)->data;
|
||||
|
||||
if (!is_symbol(val)) {
|
||||
return make_error_fmt("non-symbol found in fn argument list '%s'", \
|
||||
pr_str(val, UNREADABLY));
|
||||
}
|
||||
|
||||
if (val->value.mal_symbol[0] == '&') {
|
||||
|
||||
/* & is found but there is no symbol */
|
||||
if (val->value.mal_symbol[1] == '\0' && !(*args)->next) {
|
||||
return make_error("missing symbol after '&' in argument list");
|
||||
}
|
||||
/* & is found and there is a single symbol after */
|
||||
else if ((val->value.mal_symbol[1] == '\0' && (*args)->next &&
|
||||
is_symbol((*args)->next->data) && !(*args)->next->next)) {
|
||||
|
||||
/* TODO: check symbol is no a duplicate of one already on the list */
|
||||
*more_symbol = (*args)->next->data;
|
||||
break;
|
||||
}
|
||||
/* & is found and there extra symbols after */
|
||||
else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) {
|
||||
return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \
|
||||
pr_str((*args)->next->data, UNREADABLY), \
|
||||
pr_str((*args)->next->next->data, UNREADABLY));
|
||||
}
|
||||
/* & is found as part of the symbol and no other symbols */
|
||||
else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) {
|
||||
*more_symbol = make_symbol((val->value.mal_symbol + 1));
|
||||
break;
|
||||
}
|
||||
/* & is found as part of the symbol but there are other symbols after */
|
||||
else if (val->value.mal_symbol[1] != '\0' && (*args)->next) {
|
||||
return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \
|
||||
pr_str(val, UNREADABLY), \
|
||||
pr_str((*args)->next->data, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
/* & is not found - add the symbol to the regular argument list */
|
||||
else {
|
||||
|
||||
if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) {
|
||||
return make_error_fmt("duplicate symbol in argument list: '%s'", pr_str(val, UNREADABLY));
|
||||
}
|
||||
else {
|
||||
regular_args = list_push(regular_args, val);
|
||||
}
|
||||
}
|
||||
*args = (*args)->next;
|
||||
}
|
||||
|
||||
*args = list_reverse(regular_args);
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
char* symbol_fn(gptr data) {
|
||||
return (((MalType*)data)->value.mal_symbol);
|
||||
}
|
||||
|
||||
/* used by core functions but not EVAL as doesn't do TCE */
|
||||
MalType* apply(MalType* fn, list args) {
|
||||
|
||||
if (is_function(fn)) {
|
||||
|
||||
MalType* (*fun_ptr)(list) = fn->value.mal_function;
|
||||
return (*fun_ptr)(args);
|
||||
}
|
||||
else { /* is_closure(fn) */
|
||||
|
||||
MalClosure* c = fn->value.mal_closure;
|
||||
list params = (c->parameters)->value.mal_list;
|
||||
|
||||
long param_count = list_count(params);
|
||||
long arg_count = list_count(args);
|
||||
|
||||
if (param_count > arg_count) {
|
||||
return make_error("too few arguments supplied to function");
|
||||
}
|
||||
else if ((param_count < arg_count) && !c->more_symbol) {
|
||||
return make_error("too many arguments supplied to function");
|
||||
}
|
||||
else {
|
||||
Env* env = env_make(c->env, params, args, c->more_symbol);
|
||||
return EVAL(fn->value.mal_closure->definition, env);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
int is_macro_call(MalType* ast, Env* env) {
|
||||
|
||||
/* not a list */
|
||||
if (!is_list(ast)) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* empty list */
|
||||
list lst = ast->value.mal_list;
|
||||
if (!lst) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* first item not a symbol */
|
||||
MalType* first = lst->data;
|
||||
if (!is_symbol(first)) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* lookup symbol */
|
||||
MalType* val = env_get(env, first);
|
||||
if (is_error(val)) {
|
||||
return 0;
|
||||
}
|
||||
else {
|
||||
return (val->is_macro);
|
||||
}
|
||||
}
|
992
impls/c.2/stepA_mal.c
Normal file
992
impls/c.2/stepA_mal.c
Normal file
@ -0,0 +1,992 @@
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <ctype.h>
|
||||
#include <gc.h>
|
||||
|
||||
#include <editline/readline.h>
|
||||
#include <editline/history.h>
|
||||
|
||||
#include "types.h"
|
||||
#include "reader.h"
|
||||
#include "printer.h"
|
||||
#include "env.h"
|
||||
#include "core.h"
|
||||
|
||||
#define SYMBOL_DEFBANG "def!"
|
||||
#define SYMBOL_LETSTAR "let*"
|
||||
#define SYMBOL_DO "do"
|
||||
#define SYMBOL_IF "if"
|
||||
#define SYMBOL_FNSTAR "fn*"
|
||||
#define SYMBOL_QUOTE "quote"
|
||||
#define SYMBOL_QUASIQUOTE "quasiquote"
|
||||
#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand"
|
||||
#define SYMBOL_UNQUOTE "unquote"
|
||||
#define SYMBOL_SPLICE_UNQUOTE "splice-unquote"
|
||||
#define SYMBOL_DEFMACROBANG "defmacro!"
|
||||
#define SYMBOL_MACROEXPAND "macroexpand"
|
||||
#define SYMBOL_TRYSTAR "try*"
|
||||
#define SYMBOL_CATCHSTAR "catch*"
|
||||
|
||||
#define PROMPT_STRING "user> "
|
||||
|
||||
MalType* READ(char* str) {
|
||||
|
||||
return read_str(str);
|
||||
}
|
||||
|
||||
MalType* EVAL(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
MalType* eval_ast(MalType* ast, Env* env);
|
||||
MalType* eval_defbang(MalType* ast, Env** env);
|
||||
void eval_letstar(MalType** ast, Env** env);
|
||||
void eval_if(MalType** ast, Env** env);
|
||||
MalType* eval_fnstar(MalType* ast, Env* env);
|
||||
MalType* eval_do(MalType* ast, Env* env);
|
||||
MalType* eval_quote(MalType* ast);
|
||||
MalType* eval_quasiquote(MalType* ast);
|
||||
MalType* eval_quasiquoteexpand(MalType* ast);
|
||||
MalType* eval_defmacrobang(MalType*, Env** env);
|
||||
MalType* eval_macroexpand(MalType* ast, Env* env);
|
||||
MalType* macroexpand(MalType* ast, Env* env);
|
||||
void eval_try(MalType** ast, Env** env);
|
||||
|
||||
/* Use goto to jump here rather than calling eval for tail-call elimination */
|
||||
TCE_entry_point:
|
||||
|
||||
/* NULL */
|
||||
if (!ast) { return make_nil(); }
|
||||
|
||||
/* macroexpansion */
|
||||
ast = macroexpand(ast, env);
|
||||
if (is_error(ast)) { return ast; }
|
||||
|
||||
/* not a list */
|
||||
if (!is_list(ast)) { return eval_ast(ast, env); }
|
||||
|
||||
/* empty list */
|
||||
if (ast->value.mal_list == NULL) { return ast; }
|
||||
|
||||
/* list */
|
||||
MalType* first = (ast->value.mal_list)->data;
|
||||
char* symbol = first->value.mal_symbol;
|
||||
|
||||
if (is_symbol(first)) {
|
||||
|
||||
/* handle special symbols first */
|
||||
if (strcmp(symbol, SYMBOL_DEFBANG) == 0) {
|
||||
return eval_defbang(ast, &env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_LETSTAR) == 0) {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
eval_letstar(&ast, &env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_IF) == 0) {
|
||||
|
||||
/* TCE - modify ast directly and jump back to eval */
|
||||
eval_if(&ast, &env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_FNSTAR) == 0) {
|
||||
return eval_fnstar(ast, env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_DO) == 0) {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
ast = eval_do(ast, env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_QUOTE) == 0) {
|
||||
return eval_quote(ast);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_QUASIQUOTE) == 0) {
|
||||
|
||||
ast = eval_quasiquote(ast);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
return eval_quasiquote(make_list(lst));
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_DEFMACROBANG) == 0) {
|
||||
return eval_defmacrobang(ast, &env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_MACROEXPAND) == 0) {
|
||||
return eval_macroexpand(ast, env);
|
||||
}
|
||||
else if (strcmp(symbol, SYMBOL_TRYSTAR) == 0) {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
eval_try(&ast, &env);
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
}
|
||||
/* first element is not a special symbol */
|
||||
MalType* evaluated_list = eval_ast(ast, env);
|
||||
|
||||
if (is_error(evaluated_list)) { return evaluated_list; }
|
||||
|
||||
/* apply the first element of the list to the arguments */
|
||||
list evlst = evaluated_list->value.mal_list;
|
||||
MalType* func = evlst->data;
|
||||
|
||||
if (is_function(func)) {
|
||||
return (*func->value.mal_function)(evlst->next);
|
||||
}
|
||||
else if (is_closure(func)) {
|
||||
|
||||
MalClosure* closure = func->value.mal_closure;
|
||||
list params = (closure->parameters)->value.mal_list;
|
||||
|
||||
long param_count = list_count(params);
|
||||
long arg_count = list_count(evlst->next);
|
||||
|
||||
if (param_count > arg_count) {
|
||||
return make_error("too few arguments supplied to function");
|
||||
}
|
||||
else if ((param_count < arg_count) && !closure->more_symbol) {
|
||||
return make_error("too many arguments supplied to function");
|
||||
}
|
||||
else {
|
||||
|
||||
/* TCE - modify ast and env directly and jump back to eval */
|
||||
env = env_make(closure->env, params, evlst->next, closure->more_symbol);
|
||||
ast = func->value.mal_closure->definition;
|
||||
|
||||
if (is_error(ast)) { return ast; }
|
||||
goto TCE_entry_point;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return make_error_fmt("first item in list is not callable: '%s'", \
|
||||
pr_str(func, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
void PRINT(MalType* val) {
|
||||
|
||||
char* output = pr_str(val, READABLY);
|
||||
printf("%s\n", output);
|
||||
}
|
||||
|
||||
void rep(char* str, Env* env) {
|
||||
|
||||
PRINT(EVAL(READ(str), env));
|
||||
}
|
||||
|
||||
/* declare as global so it can be accessed by mal_eval */
|
||||
Env* global_env;
|
||||
|
||||
MalType* mal_eval(list args) {
|
||||
|
||||
MalType* ast = args->data;
|
||||
return EVAL(ast, global_env);
|
||||
}
|
||||
|
||||
MalType* mal_readline(list args) {
|
||||
|
||||
if (!args || args->next) {
|
||||
return make_error("'readline': expected exactly one argument");
|
||||
}
|
||||
|
||||
MalType* prompt = args->data;
|
||||
|
||||
if (!is_string(prompt)) {
|
||||
return make_error_fmt("'readline': argument is not a string '%s'", \
|
||||
pr_str(prompt, UNREADABLY));
|
||||
}
|
||||
|
||||
char* str = readline(prompt->value.mal_string);
|
||||
|
||||
if (str) {
|
||||
add_history(str);
|
||||
return make_string(str);
|
||||
}
|
||||
else {
|
||||
return make_nil();
|
||||
}
|
||||
}
|
||||
|
||||
int main(int argc, char** argv) {
|
||||
|
||||
Env* repl_env = env_make(NULL, NULL, NULL, NULL);
|
||||
global_env = repl_env;
|
||||
|
||||
ns* core = ns_make_core();
|
||||
hashmap mappings = core->mappings;
|
||||
|
||||
while (mappings) {
|
||||
char* symbol = mappings->data;
|
||||
MalType*(*function)(list) = mappings->next->data;
|
||||
|
||||
env_set_C_fn(repl_env, symbol, function);
|
||||
|
||||
/* pop symbol and function from hashmap/list */
|
||||
mappings = mappings->next->next;
|
||||
}
|
||||
|
||||
env_set_C_fn(repl_env, "eval", mal_eval);
|
||||
env_set_C_fn(repl_env, "readline", mal_readline);
|
||||
|
||||
/* add functions written in mal - not using rep as it prints the result */
|
||||
EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env);
|
||||
EVAL(READ("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))"), repl_env);
|
||||
EVAL(READ("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))"), repl_env);
|
||||
|
||||
/* make command line arguments available in the environment */
|
||||
list lst = NULL;
|
||||
for (long i = 2; i < argc; i++) {
|
||||
lst = list_push(lst, make_string(argv[i]));
|
||||
}
|
||||
env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst)));
|
||||
env_set(repl_env, make_symbol("*host-language*"), make_string("c.2"));
|
||||
|
||||
/* run in script mode if a filename is given */
|
||||
if (argc > 1) {
|
||||
|
||||
/* first argument on command line is filename */
|
||||
char* load_command = snprintfbuf(1024, "(load-file \"%s\")", argv[1]);
|
||||
EVAL(READ(load_command), repl_env);
|
||||
}
|
||||
/* run in repl mode when no cmd line args */
|
||||
else {
|
||||
|
||||
/* Greeting message */
|
||||
EVAL(READ("(println (str \"Mal [\" *host-language* \"]\"))"), repl_env);
|
||||
|
||||
while (1) {
|
||||
|
||||
/* print prompt and get input*/
|
||||
/* readline allocates memory for input */
|
||||
char* input = readline(PROMPT_STRING);
|
||||
|
||||
/* Check for EOF (Ctrl-D) */
|
||||
if (!input) {
|
||||
printf("\n");
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* add input to history */
|
||||
add_history(input);
|
||||
|
||||
/* call Read-Eval-Print */
|
||||
rep(input, repl_env);
|
||||
|
||||
/* have to release the memory used by readline */
|
||||
free(input);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
MalType* eval_ast(MalType* ast, Env* env) {
|
||||
|
||||
/* forward references */
|
||||
list evaluate_list(list lst, Env* env);
|
||||
list evaluate_vector(list lst, Env* env);
|
||||
list evaluate_hashmap(list lst, Env* env);
|
||||
|
||||
if (is_symbol(ast)) {
|
||||
|
||||
MalType* symbol_value = env_get(env, ast);
|
||||
|
||||
if (symbol_value) {
|
||||
return symbol_value;
|
||||
} else {
|
||||
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
|
||||
}
|
||||
}
|
||||
else if (is_list(ast)) {
|
||||
|
||||
list result = evaluate_list(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_list(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_vector(ast)) {
|
||||
|
||||
list result = evaluate_vector(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_vector(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else if (is_hashmap(ast)) {
|
||||
|
||||
list result = evaluate_hashmap(ast->value.mal_list, env);
|
||||
|
||||
if (!result || !is_error(result->data)) {
|
||||
return make_hashmap(result);
|
||||
} else {
|
||||
return result->data;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return ast;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_defbang(MalType* ast, Env** env) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
if (!lst || !lst->next || lst->next->next) {
|
||||
return make_error_fmt("'def!': expected exactly two arguments");
|
||||
}
|
||||
|
||||
MalType* defbang_symbol = lst->data;
|
||||
|
||||
if (!is_symbol(defbang_symbol)) {
|
||||
return make_error_fmt("'def!': expected symbol for first argument");
|
||||
}
|
||||
|
||||
MalType* defbang_value = lst->next->data;
|
||||
MalType* result = EVAL(defbang_value, *env);
|
||||
|
||||
if (!is_error(result)){
|
||||
*env = env_set(*env, defbang_symbol, result);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
void eval_letstar(MalType** ast, Env** env) {
|
||||
|
||||
list lst = (*ast)->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
*ast = make_error("'let*': missing bindings list");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* bindings = lst->next->data;
|
||||
MalType* forms = lst->next->next ? lst->next->next->data : make_nil();
|
||||
|
||||
if (!is_sequential(bindings)) {
|
||||
*ast = make_error("'let*': first argument is not list or vector");
|
||||
return;
|
||||
}
|
||||
|
||||
list bindings_list = bindings->value.mal_list;
|
||||
if (list_count(bindings_list) % 2 == 1) {
|
||||
*ast = make_error("'let*': expected an even number of binding pairs");
|
||||
return;
|
||||
}
|
||||
|
||||
Env* letstar_env = env_make(*env, NULL, NULL, NULL);
|
||||
|
||||
/* evaluate the bindings */
|
||||
while(bindings_list) {
|
||||
|
||||
MalType* symbol = bindings_list->data;
|
||||
MalType* value = EVAL(bindings_list->next->data, letstar_env);
|
||||
|
||||
/* early return from error */
|
||||
if (is_error(value)) {
|
||||
*ast = value;
|
||||
return;
|
||||
}
|
||||
|
||||
env_set(letstar_env, symbol, value);
|
||||
bindings_list = bindings_list->next->next;
|
||||
}
|
||||
|
||||
*env = letstar_env;
|
||||
*ast = forms;
|
||||
return;
|
||||
}
|
||||
|
||||
void eval_if(MalType** ast, Env** env) {
|
||||
|
||||
list lst = (*ast)->value.mal_list;
|
||||
|
||||
if (!lst->next || !lst->next->next) {
|
||||
*ast = make_error("'if': too few arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
if (lst->next->next->next && lst->next->next->next->next) {
|
||||
*ast = make_error("'if': too many arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* condition = EVAL(lst->next->data, *env);
|
||||
|
||||
if (is_error(condition)) {
|
||||
*ast = condition;
|
||||
return;
|
||||
}
|
||||
|
||||
if (is_false(condition) || is_nil(condition)) {
|
||||
|
||||
/* check whether false branch is present */
|
||||
if (lst->next->next->next) {
|
||||
*ast = lst->next->next->next->data;
|
||||
return;
|
||||
}
|
||||
else {
|
||||
*ast = make_nil();
|
||||
return;
|
||||
}
|
||||
|
||||
} else {
|
||||
*ast = lst->next->next->data;
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_fnstar(MalType* ast, Env* env) {
|
||||
|
||||
/* forward reference */
|
||||
MalType* regularise_parameters(list* params, MalType** more);
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
return make_error("'fn*': missing argument list");
|
||||
}
|
||||
else if (!lst->next->next) {
|
||||
return make_error("'fn*': missing function body");
|
||||
}
|
||||
|
||||
MalType* params = lst->next->data;
|
||||
list params_list = params->value.mal_list;
|
||||
|
||||
MalType* more_symbol = NULL;
|
||||
|
||||
MalType* result = regularise_parameters(¶ms_list, &more_symbol);
|
||||
if (is_error(result)) { return result; }
|
||||
|
||||
MalType* definition = lst->next->next->data;
|
||||
MalType* regular_params = make_list(params_list);
|
||||
|
||||
return make_closure(env, regular_params, definition, more_symbol);
|
||||
}
|
||||
|
||||
MalType* eval_do(MalType* ast, Env* env) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
/* handle empty 'do' */
|
||||
if (!lst->next) {
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
/* evaluate all but the last form */
|
||||
lst = lst->next;
|
||||
while (lst->next) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
/* return error early */
|
||||
if (is_error(val)) {
|
||||
return val;
|
||||
}
|
||||
lst = lst->next;
|
||||
}
|
||||
/* return the last form for TCE evaluation */
|
||||
return lst->data;
|
||||
}
|
||||
|
||||
MalType* eval_quote(MalType* ast) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
if (!lst) {
|
||||
return make_nil();
|
||||
}
|
||||
else if (lst->next) {
|
||||
return make_error("'quote': expected exactly one argument");
|
||||
}
|
||||
else {
|
||||
return lst->data;
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_quasiquote(MalType* ast) {
|
||||
|
||||
/* forward reference */
|
||||
MalType* quasiquote(MalType* ast);
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
/* no arguments (quasiquote) */
|
||||
if (!lst->next) {
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
/* too many arguments */
|
||||
else if (lst->next->next) {
|
||||
return make_error("'quasiquote': expected exactly one argument");
|
||||
}
|
||||
return quasiquote(lst->next->data);
|
||||
}
|
||||
|
||||
MalType* quasiquote(MalType* ast) {
|
||||
|
||||
/* forward references */
|
||||
MalType* quasiquote_list(MalType* ast);
|
||||
MalType* quasiquote_vector(MalType* ast);
|
||||
|
||||
/* argument to quasiquote is self-evaluating: (quasiquote val)
|
||||
=> val */
|
||||
if (is_self_evaluating(ast)) {
|
||||
return ast;
|
||||
}
|
||||
|
||||
/* argument to quasiquote is a vector: (quasiquote [first rest]) */
|
||||
else if (is_vector(ast)) {
|
||||
|
||||
return quasiquote_vector(ast);
|
||||
}
|
||||
|
||||
/* argument to quasiquote is a list: (quasiquote (first rest)) */
|
||||
else if (is_list(ast)){
|
||||
|
||||
return quasiquote_list(ast);
|
||||
}
|
||||
/* argument to quasiquote is not self-evaluating and isn't sequential: (quasiquote val)
|
||||
=> (quote val) */
|
||||
else {
|
||||
|
||||
list lst = list_make(ast);
|
||||
lst = list_push(lst, make_symbol("quote"));
|
||||
return make_list(lst);
|
||||
}
|
||||
}
|
||||
|
||||
MalType* quasiquote_vector(MalType* ast) {
|
||||
|
||||
/* forward references */
|
||||
MalType* quasiquote_list(MalType* ast);
|
||||
|
||||
list args = ast->value.mal_list;
|
||||
|
||||
if (args) {
|
||||
|
||||
MalType* first = args->data;
|
||||
|
||||
/* if first element is unquote return quoted */
|
||||
if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0) {
|
||||
|
||||
list lst = list_make(ast);
|
||||
lst = list_push(lst, make_symbol("quote"));
|
||||
|
||||
return make_list(lst);
|
||||
}
|
||||
}
|
||||
|
||||
/* otherwise process like a list */
|
||||
|
||||
list lst = list_make(make_symbol("vec"));
|
||||
|
||||
MalType* result = quasiquote_list(ast);
|
||||
|
||||
if (is_error(result)) {
|
||||
return result;
|
||||
} else {
|
||||
lst = list_push(lst, result);
|
||||
}
|
||||
|
||||
lst = list_reverse(lst);
|
||||
return make_list(lst);
|
||||
}
|
||||
|
||||
MalType* quasiquote_list(MalType* ast) {
|
||||
|
||||
list args = ast->value.mal_list;
|
||||
|
||||
/* handle empty list: (quasiquote ())
|
||||
=> () */
|
||||
if (!args) {
|
||||
return make_list(NULL);
|
||||
}
|
||||
|
||||
MalType* first = args->data;
|
||||
|
||||
/* handle unquote: (quasiquote (unquote second))
|
||||
=> second */
|
||||
if (is_symbol(first) && strcmp(first->value.mal_symbol, SYMBOL_UNQUOTE) == 0 && args->next) {
|
||||
|
||||
if (args->next->next) {
|
||||
return make_error("'quasiquote': unquote expected exactly one argument");
|
||||
}
|
||||
else {
|
||||
return args->next->data;
|
||||
}
|
||||
}
|
||||
|
||||
/* handle splice-unquote: (quasiquote ((splice-unquote first-second) rest))
|
||||
=> (concat first-second (quasiquote rest)) */
|
||||
else if (is_list(first) &&
|
||||
first->value.mal_list != NULL &&
|
||||
is_symbol(first->value.mal_list->data) &&
|
||||
strcmp(((MalType*)first->value.mal_list->data)->value.mal_symbol, SYMBOL_SPLICE_UNQUOTE) == 0) {
|
||||
|
||||
if (!first->value.mal_list->next) {
|
||||
return make_error("'quasiquote': splice-unquote expected exactly one argument");
|
||||
}
|
||||
|
||||
MalType* first_second = first->value.mal_list->next->data;
|
||||
list lst = list_make(make_symbol("concat"));
|
||||
lst = list_push(lst, first_second);
|
||||
|
||||
MalType* rest = quasiquote(make_list(args->next));
|
||||
if (is_error(rest)) {
|
||||
return rest;
|
||||
}
|
||||
|
||||
lst = list_push(lst, rest);
|
||||
lst = list_reverse(lst);
|
||||
|
||||
return make_list(lst);
|
||||
}
|
||||
/* handle all other lists recursively: (quasiquote (first rest))
|
||||
=> (cons (quasiquote first) (quasiquote rest)) */
|
||||
else {
|
||||
|
||||
list lst = list_make(make_symbol("cons"));
|
||||
|
||||
MalType* first = quasiquote(args->data);
|
||||
if (is_error(first)) {
|
||||
return first;
|
||||
} else {
|
||||
lst = list_push(lst, first);
|
||||
}
|
||||
|
||||
MalType* rest = quasiquote(make_list(args->next));
|
||||
if (is_error(rest)) {
|
||||
return rest;
|
||||
} else {
|
||||
lst = list_push(lst, rest);
|
||||
}
|
||||
|
||||
lst = list_reverse(lst);
|
||||
return make_list(lst);
|
||||
}
|
||||
}
|
||||
|
||||
MalType* eval_defmacrobang(MalType* ast, Env** env) {
|
||||
|
||||
list lst = (ast->value.mal_list)->next;
|
||||
|
||||
if (!lst || !lst->next || lst->next->next) {
|
||||
return make_error_fmt("'defmacro!': expected exactly two arguments");
|
||||
}
|
||||
|
||||
MalType* defbang_symbol = lst->data;
|
||||
|
||||
if (!is_symbol(defbang_symbol)) {
|
||||
return make_error_fmt("'defmacro!': expected symbol for first argument");
|
||||
}
|
||||
|
||||
MalType* defbang_value = lst->next->data;
|
||||
MalType* result = EVAL(defbang_value, *env);
|
||||
|
||||
if (!is_error(result)) {
|
||||
result = copy_type(result);
|
||||
result->is_macro = 1;
|
||||
*env = env_set(*env, defbang_symbol, result);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
MalType* eval_macroexpand(MalType* ast, Env* env) {
|
||||
|
||||
/* forward reference */
|
||||
MalType* macroexpand(MalType* ast, Env* env);
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
return make_nil();
|
||||
}
|
||||
else if (lst->next->next) {
|
||||
return make_error("'macroexpand': expected exactly one argument");
|
||||
}
|
||||
else {
|
||||
return macroexpand(lst->next->data, env);
|
||||
}
|
||||
}
|
||||
|
||||
MalType* macroexpand(MalType* ast, Env* env) {
|
||||
|
||||
/* forward reference */
|
||||
int is_macro_call(MalType* ast, Env* env);
|
||||
|
||||
while(is_macro_call(ast, env)) {
|
||||
|
||||
list lst = ast->value.mal_list;
|
||||
|
||||
MalType* macro_fn = env_get(env, lst->data);
|
||||
MalClosure* cls = macro_fn->value.mal_closure;
|
||||
MalType* more_symbol = cls->more_symbol;
|
||||
|
||||
list params_list = (cls->parameters)->value.mal_list;
|
||||
list args_list = lst->next;
|
||||
|
||||
env = env_make(cls->env, params_list, args_list, more_symbol);
|
||||
ast = EVAL(cls->definition, env);
|
||||
}
|
||||
return ast;
|
||||
}
|
||||
|
||||
void eval_try(MalType** ast, Env** env) {
|
||||
|
||||
list lst = (*ast)->value.mal_list;
|
||||
|
||||
if (!lst->next) {
|
||||
*ast = make_nil();
|
||||
return;
|
||||
}
|
||||
|
||||
if (lst->next->next && lst->next->next->next) {
|
||||
*ast = make_error("'try*': expected maximum of two arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* try_clause = lst->next->data;
|
||||
MalType* try_result = EVAL(try_clause, *env);
|
||||
|
||||
/* no catch* clause */
|
||||
if (!is_error(try_result) || !lst->next->next) {
|
||||
*ast = try_result;
|
||||
return;
|
||||
}
|
||||
|
||||
/* process catch* clause */
|
||||
MalType* catch_clause = lst->next->next->data;
|
||||
list catch_list = catch_clause->value.mal_list;
|
||||
|
||||
if (!catch_list) {
|
||||
*ast = make_error("'try*': catch* clause is empty");
|
||||
return;
|
||||
}
|
||||
|
||||
MalType* catch_symbol = catch_list->data;
|
||||
if (strcmp(catch_symbol->value.mal_symbol, SYMBOL_CATCHSTAR) != 0) {
|
||||
*ast = make_error("Error: catch clause is missing catch* symbol");
|
||||
return;
|
||||
}
|
||||
|
||||
if (!catch_list->next || !catch_list->next->next) {
|
||||
*ast = make_error("Error: catch* clause expected two arguments");
|
||||
return;
|
||||
}
|
||||
|
||||
if (!is_symbol(catch_list->next->data)) {
|
||||
*ast = make_error("Error: catch* clause expected a symbol");
|
||||
return;
|
||||
}
|
||||
|
||||
/* bind the symbol to the exception */
|
||||
list symbol_list = list_make(catch_list->next->data);
|
||||
list expr_list = list_make(try_result->value.mal_error);
|
||||
|
||||
Env* catch_env = env_make(*env, symbol_list, expr_list, NULL);
|
||||
*ast = catch_list->next->next->data;
|
||||
*env = catch_env;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
list evaluate_list(list lst, Env* env) {
|
||||
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_vector(list lst, Env* env) {
|
||||
/* TODO: implement a real vector */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
list evaluate_hashmap(list lst, Env* env) {
|
||||
/* TODO: implement a real hashmap */
|
||||
list evlst = NULL;
|
||||
while (lst) {
|
||||
|
||||
/* keys are unevaluated */
|
||||
evlst = list_push(evlst, lst->data);
|
||||
lst = lst->next;
|
||||
|
||||
/* values are evaluated */
|
||||
MalType* val = EVAL(lst->data, env);
|
||||
|
||||
if (is_error(val)) {
|
||||
return list_make(val);
|
||||
}
|
||||
|
||||
evlst = list_push(evlst, val);
|
||||
lst = lst->next;
|
||||
}
|
||||
return list_reverse(evlst);
|
||||
}
|
||||
|
||||
MalType* regularise_parameters(list* args, MalType** more_symbol) {
|
||||
|
||||
/* forward reference */
|
||||
char* symbol_fn(gptr data);
|
||||
|
||||
list regular_args = NULL;
|
||||
while (*args) {
|
||||
|
||||
MalType* val = (*args)->data;
|
||||
|
||||
if (!is_symbol(val)) {
|
||||
return make_error_fmt("non-symbol found in fn argument list '%s'", \
|
||||
pr_str(val, UNREADABLY));
|
||||
}
|
||||
|
||||
if (val->value.mal_symbol[0] == '&') {
|
||||
|
||||
/* & is found but there is no symbol */
|
||||
if (val->value.mal_symbol[1] == '\0' && !(*args)->next) {
|
||||
return make_error("missing symbol after '&' in argument list");
|
||||
}
|
||||
/* & is found and there is a single symbol after */
|
||||
else if ((val->value.mal_symbol[1] == '\0' && (*args)->next &&
|
||||
is_symbol((*args)->next->data) && !(*args)->next->next)) {
|
||||
|
||||
*more_symbol = (*args)->next->data;
|
||||
break;
|
||||
}
|
||||
/* & is found and there extra symbols after */
|
||||
else if ((val->value.mal_symbol[1] == '\0' && (*args)->next && (*args)->next->next)) {
|
||||
return make_error_fmt("unexpected symbol after '& %s' in argument list: '%s'", \
|
||||
pr_str((*args)->next->data, UNREADABLY), \
|
||||
pr_str((*args)->next->next->data, UNREADABLY));
|
||||
}
|
||||
/* & is found as part of the symbol and no other symbols */
|
||||
else if (val->value.mal_symbol[1] != '\0' && !(*args)->next) {
|
||||
*more_symbol = make_symbol((val->value.mal_symbol + 1));
|
||||
break;
|
||||
}
|
||||
/* & is found as part of the symbol but there are other symbols after */
|
||||
else if (val->value.mal_symbol[1] != '\0' && (*args)->next) {
|
||||
return make_error_fmt("unexpected symbol after '%s' in argument list: '%s'", \
|
||||
pr_str(val, UNREADABLY), \
|
||||
pr_str((*args)->next->data, UNREADABLY));
|
||||
}
|
||||
}
|
||||
|
||||
/* & is not found - add the symbol to the regular argument list */
|
||||
else {
|
||||
|
||||
if (list_findf(regular_args, val->value.mal_symbol, symbol_fn) > 0) {
|
||||
return make_error_fmt("duplicate symbol in argument list: '%s'", \
|
||||
pr_str(val, UNREADABLY));
|
||||
}
|
||||
else {
|
||||
regular_args = list_push(regular_args, val);
|
||||
}
|
||||
}
|
||||
*args = (*args)->next;
|
||||
}
|
||||
|
||||
*args = list_reverse(regular_args);
|
||||
return make_nil();
|
||||
}
|
||||
|
||||
char* symbol_fn(gptr data) {
|
||||
return (((MalType*)data)->value.mal_symbol);
|
||||
}
|
||||
|
||||
/* used by core functions but not EVAL as doesn't do TCE */
|
||||
MalType* apply(MalType* fn, list args) {
|
||||
|
||||
if (is_function(fn)) {
|
||||
|
||||
MalType* (*fun_ptr)(list) = fn->value.mal_function;
|
||||
return (*fun_ptr)(args);
|
||||
}
|
||||
else { /* is_closure(fn) */
|
||||
|
||||
MalClosure* c = fn->value.mal_closure;
|
||||
list params = (c->parameters)->value.mal_list;
|
||||
|
||||
long param_count = list_count(params);
|
||||
long arg_count = list_count(args);
|
||||
|
||||
if (param_count > arg_count) {
|
||||
return make_error("too few arguments supplied to function");
|
||||
}
|
||||
else if ((param_count < arg_count) && !c->more_symbol) {
|
||||
return make_error("too many arguments supplied to function");
|
||||
}
|
||||
else {
|
||||
Env* env = env_make(c->env, params, args, c->more_symbol);
|
||||
return EVAL(fn->value.mal_closure->definition, env);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
int is_macro_call(MalType* ast, Env* env) {
|
||||
|
||||
/* not a list */
|
||||
if (!is_list(ast)) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* empty list */
|
||||
list lst = ast->value.mal_list;
|
||||
if (!lst) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* first item not a symbol */
|
||||
MalType* first = lst->data;
|
||||
if (!is_symbol(first)) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* lookup symbol */
|
||||
MalType* val = env_get(env, first);
|
||||
if (is_error(val)) {
|
||||
return 0;
|
||||
}
|
||||
else {
|
||||
return (val->is_macro);
|
||||
}
|
||||
}
|
22
impls/c.2/tests/stepA_mal.mal
Normal file
22
impls/c.2/tests/stepA_mal.mal
Normal file
@ -0,0 +1,22 @@
|
||||
;; Testing FFI of "strlen"
|
||||
(. nil "int32" "strlen" "string" "abcde")
|
||||
;=>5
|
||||
(. nil "int32" "strlen" "string" "")
|
||||
;=>0
|
||||
|
||||
;; Testing FFI of "strcmp"
|
||||
|
||||
(. nil "int32" "strcmp" "string" "abc" "string" "abcA")
|
||||
;=>-65
|
||||
(. nil "int32" "strcmp" "string" "abcA" "string" "abc")
|
||||
;=>65
|
||||
(. nil "int32" "strcmp" "string" "abc" "string" "abc")
|
||||
;=>0
|
||||
|
||||
|
||||
;; Testing FFI of "pow" (libm.so)
|
||||
|
||||
(. "libm.so.6" "double" "pow" "double" 2.0 "double" 3.0)
|
||||
;=>8.000000
|
||||
(. "libm.so.6" "double" "pow" "double" 3.0 "double" 2.0)
|
||||
;=>9.000000
|
283
impls/c.2/types.c
Normal file
283
impls/c.2/types.c
Normal file
@ -0,0 +1,283 @@
|
||||
#include <stdarg.h>
|
||||
#include <stdio.h>
|
||||
#include <gc.h>
|
||||
#include "types.h"
|
||||
|
||||
#define ERROR_BUFFER_SIZE 128
|
||||
|
||||
MalType THE_TRUE = {MALTYPE_TRUE, 0, 0, {0}};
|
||||
MalType THE_FALSE = {MALTYPE_FALSE, 0, 0, {0}};
|
||||
MalType THE_NIL = {MALTYPE_NIL, 0, 0, {0}};
|
||||
|
||||
|
||||
inline int is_sequential(MalType* val) {
|
||||
return (val->type == MALTYPE_LIST || val->type == MALTYPE_VECTOR);
|
||||
}
|
||||
|
||||
inline int is_self_evaluating(MalType* val) {
|
||||
return (val->type == MALTYPE_KEYWORD || val->type == MALTYPE_INTEGER ||
|
||||
val->type == MALTYPE_FLOAT || val->type == MALTYPE_STRING ||
|
||||
val->type == MALTYPE_TRUE || val->type == MALTYPE_FALSE ||
|
||||
val->type == MALTYPE_NIL);
|
||||
}
|
||||
|
||||
inline int is_list(MalType* val) {
|
||||
return (val->type == MALTYPE_LIST);
|
||||
}
|
||||
|
||||
inline int is_vector(MalType* val) {
|
||||
return (val->type == MALTYPE_VECTOR);
|
||||
}
|
||||
|
||||
inline int is_hashmap(MalType* val) {
|
||||
return (val->type == MALTYPE_HASHMAP);
|
||||
}
|
||||
|
||||
inline int is_nil(MalType* val) {
|
||||
return (val->type == MALTYPE_NIL);
|
||||
}
|
||||
|
||||
inline int is_string(MalType* val) {
|
||||
return (val->type == MALTYPE_STRING);
|
||||
}
|
||||
|
||||
inline int is_integer(MalType* val) {
|
||||
return (val->type == MALTYPE_INTEGER);
|
||||
}
|
||||
|
||||
inline int is_float(MalType* val) {
|
||||
return (val->type == MALTYPE_FLOAT);
|
||||
}
|
||||
|
||||
inline int is_number(MalType* val) {
|
||||
return (val->type == MALTYPE_INTEGER || val->type == MALTYPE_FLOAT);
|
||||
}
|
||||
|
||||
inline int is_true(MalType* val) {
|
||||
return (val->type == MALTYPE_TRUE);
|
||||
}
|
||||
|
||||
inline int is_false(MalType* val) {
|
||||
return (val->type == MALTYPE_FALSE);
|
||||
}
|
||||
|
||||
inline int is_symbol(MalType* val) {
|
||||
return (val->type == MALTYPE_SYMBOL);
|
||||
}
|
||||
|
||||
inline int is_keyword(MalType* val) {
|
||||
return (val->type == MALTYPE_KEYWORD);
|
||||
}
|
||||
|
||||
inline int is_atom(MalType* val) {
|
||||
return (val->type == MALTYPE_ATOM);
|
||||
}
|
||||
|
||||
inline int is_error(MalType* val) {
|
||||
return (val->type == MALTYPE_ERROR);
|
||||
}
|
||||
|
||||
inline int is_callable(MalType* val) {
|
||||
return (val->type == MALTYPE_FUNCTION || val->type == MALTYPE_CLOSURE);
|
||||
}
|
||||
|
||||
inline int is_function(MalType* val) {
|
||||
return (val->type == MALTYPE_FUNCTION);
|
||||
}
|
||||
|
||||
inline int is_closure(MalType* val) {
|
||||
return (val->type == MALTYPE_CLOSURE);
|
||||
}
|
||||
|
||||
inline int is_macro(MalType* val) {
|
||||
return (val->is_macro);
|
||||
}
|
||||
|
||||
|
||||
MalType* make_symbol(char* value) {
|
||||
|
||||
MalType* mal_val = GC_MALLOC(sizeof(*mal_val));
|
||||
mal_val->type = MALTYPE_SYMBOL;
|
||||
mal_val->value.mal_symbol = value;
|
||||
mal_val->metadata = NULL;
|
||||
|
||||
return mal_val;
|
||||
}
|
||||
|
||||
MalType* make_integer(long value) {
|
||||
|
||||
MalType* mal_val = GC_MALLOC(sizeof(*mal_val));
|
||||
mal_val->type = MALTYPE_INTEGER;
|
||||
mal_val->value.mal_integer = value;
|
||||
mal_val->metadata = NULL;
|
||||
|
||||
return mal_val;
|
||||
}
|
||||
|
||||
MalType* make_float(double value) {
|
||||
|
||||
MalType* mal_val = GC_MALLOC(sizeof(*mal_val));
|
||||
mal_val->type = MALTYPE_FLOAT;
|
||||
mal_val->value.mal_float = value;
|
||||
mal_val->metadata = NULL;
|
||||
|
||||
return mal_val;
|
||||
}
|
||||
|
||||
MalType* make_keyword(char* value) {
|
||||
|
||||
MalType* mal_val = GC_MALLOC(sizeof(*mal_val));
|
||||
mal_val->type = MALTYPE_KEYWORD;
|
||||
mal_val->value.mal_keyword = value;
|
||||
mal_val->metadata = NULL;
|
||||
|
||||
return mal_val;
|
||||
}
|
||||
|
||||
MalType* make_string(char* value) {
|
||||
|
||||
MalType* mal_val = GC_MALLOC(sizeof(*mal_val));
|
||||
mal_val->type = MALTYPE_STRING;
|
||||
mal_val->value.mal_string = value;
|
||||
mal_val->metadata = NULL;
|
||||
|
||||
return mal_val;
|
||||
}
|
||||
|
||||
MalType* make_list(list value) {
|
||||
|
||||
MalType* mal_val = GC_MALLOC(sizeof(*mal_val));
|
||||
mal_val->type = MALTYPE_LIST;
|
||||
mal_val->value.mal_list = value;
|
||||
mal_val->metadata = NULL;
|
||||
|
||||
return mal_val;
|
||||
}
|
||||
|
||||
MalType* make_vector(list value) {
|
||||
|
||||
MalType* mal_val = GC_MALLOC(sizeof(*mal_val));
|
||||
mal_val->type = MALTYPE_VECTOR;
|
||||
mal_val->value.mal_list = value;
|
||||
mal_val->metadata = NULL;
|
||||
|
||||
return mal_val;
|
||||
}
|
||||
|
||||
MalType* make_hashmap(list value) {
|
||||
|
||||
MalType* mal_val = GC_MALLOC(sizeof(*mal_val));
|
||||
mal_val->type = MALTYPE_HASHMAP;
|
||||
mal_val->value.mal_list = value;
|
||||
mal_val->metadata = NULL;
|
||||
|
||||
return mal_val;
|
||||
}
|
||||
|
||||
MalType* make_atom(MalType* value) {
|
||||
|
||||
MalType* mal_val = GC_MALLOC(sizeof(*mal_val));
|
||||
mal_val->type = MALTYPE_ATOM;
|
||||
mal_val->value.mal_atom = value;
|
||||
mal_val->metadata = NULL;
|
||||
|
||||
return mal_val;
|
||||
}
|
||||
|
||||
MalType* make_function(MalType*(*fn)(list args)) {
|
||||
|
||||
MalType* mal_val = GC_MALLOC(sizeof(*mal_val));
|
||||
mal_val->type = MALTYPE_FUNCTION;
|
||||
mal_val->value.mal_function = fn;
|
||||
mal_val->is_macro = 0;
|
||||
mal_val->metadata = NULL;
|
||||
|
||||
return mal_val;
|
||||
}
|
||||
|
||||
MalType* make_closure(Env* env, MalType* parameters, MalType* definition, MalType* more_symbol) {
|
||||
|
||||
MalType* mal_val = GC_MALLOC(sizeof(*mal_val));
|
||||
mal_val->type = MALTYPE_CLOSURE;
|
||||
mal_val->metadata = NULL;
|
||||
|
||||
/* Allocate memory for embedded struct */
|
||||
MalClosure* mc = GC_MALLOC(sizeof(*mc));
|
||||
mc->env = env;
|
||||
mc->parameters = parameters;
|
||||
mc->definition = definition;
|
||||
mc->more_symbol = more_symbol;
|
||||
|
||||
mal_val->is_macro = 0;
|
||||
mal_val->value.mal_closure = mc;
|
||||
return mal_val;
|
||||
}
|
||||
|
||||
inline MalType* make_true() {
|
||||
return &THE_TRUE;
|
||||
}
|
||||
|
||||
inline MalType* make_false() {
|
||||
return &THE_FALSE;
|
||||
}
|
||||
|
||||
inline MalType* make_nil() {
|
||||
return &THE_NIL;
|
||||
}
|
||||
|
||||
MalType* make_error(char* msg) {
|
||||
|
||||
MalType* mal_string = GC_MALLOC(sizeof(*mal_string));
|
||||
mal_string->type = MALTYPE_STRING;
|
||||
mal_string->value.mal_string = msg;
|
||||
|
||||
MalType* mal_val = GC_MALLOC(sizeof(*mal_val));
|
||||
mal_val->type = MALTYPE_ERROR;
|
||||
mal_val->value.mal_error = mal_string;
|
||||
mal_val->metadata = NULL;
|
||||
|
||||
return mal_val;
|
||||
}
|
||||
|
||||
MalType* make_error_fmt(char* fmt, ...) {
|
||||
|
||||
va_list argptr;
|
||||
va_start(argptr, fmt);
|
||||
|
||||
char* buffer = GC_MALLOC(sizeof(*buffer) * ERROR_BUFFER_SIZE);
|
||||
|
||||
long n = vsnprintf(buffer, ERROR_BUFFER_SIZE, fmt, argptr);
|
||||
va_end(argptr);
|
||||
|
||||
if (n > ERROR_BUFFER_SIZE) {
|
||||
va_start(argptr, fmt);
|
||||
|
||||
buffer = GC_REALLOC(buffer, sizeof(*buffer) * n);
|
||||
vsnprintf(buffer, n, fmt, argptr);
|
||||
|
||||
va_end(argptr);
|
||||
}
|
||||
return make_error(buffer);
|
||||
}
|
||||
|
||||
MalType* wrap_error(MalType* value) {
|
||||
|
||||
MalType* mal_error = GC_MALLOC(sizeof(*mal_error));
|
||||
mal_error->type = MALTYPE_ERROR;
|
||||
mal_error->metadata = NULL;
|
||||
mal_error->value.mal_error = value;
|
||||
|
||||
return mal_error;
|
||||
}
|
||||
|
||||
MalType* copy_type(MalType* value) {
|
||||
|
||||
MalType* new_val = GC_MALLOC(sizeof(*new_val));
|
||||
|
||||
new_val->type = value->type;
|
||||
new_val->is_macro = value->is_macro;
|
||||
new_val->value = value->value;
|
||||
new_val->metadata = value->metadata;
|
||||
|
||||
return new_val;
|
||||
}
|
100
impls/c.2/types.h
Normal file
100
impls/c.2/types.h
Normal file
@ -0,0 +1,100 @@
|
||||
#ifndef _MAL_TYPES_H
|
||||
#define _MAL_TYPES_H
|
||||
|
||||
#include "libs/linked_list/linked_list.h"
|
||||
#include "libs/hashmap/hashmap.h"
|
||||
|
||||
#define MALTYPE_SYMBOL 1
|
||||
#define MALTYPE_KEYWORD 2
|
||||
#define MALTYPE_INTEGER 3
|
||||
#define MALTYPE_FLOAT 4
|
||||
#define MALTYPE_STRING 5
|
||||
#define MALTYPE_TRUE 6
|
||||
#define MALTYPE_FALSE 7
|
||||
#define MALTYPE_NIL 8
|
||||
#define MALTYPE_LIST 9
|
||||
#define MALTYPE_VECTOR 10
|
||||
#define MALTYPE_HASHMAP 11
|
||||
#define MALTYPE_FUNCTION 12
|
||||
#define MALTYPE_CLOSURE 13
|
||||
#define MALTYPE_ERROR 14
|
||||
#define MALTYPE_ATOM 15
|
||||
|
||||
typedef struct MalType_s MalType;
|
||||
typedef struct MalClosure_s MalClosure;
|
||||
typedef struct Env_s Env;
|
||||
|
||||
struct MalType_s {
|
||||
|
||||
int type;
|
||||
int is_macro;
|
||||
MalType* metadata;
|
||||
|
||||
union MalValue {
|
||||
|
||||
long mal_integer;
|
||||
double mal_float;
|
||||
char* mal_symbol;
|
||||
char* mal_string;
|
||||
char* mal_keyword;
|
||||
list mal_list;
|
||||
/* vector mal_vector; TODO: implement a real vector */
|
||||
/* hashmap mal_hashmap; TODO: implement a real hashmap */
|
||||
MalType* (*mal_function)(list);
|
||||
MalClosure* mal_closure;
|
||||
MalType* mal_atom;
|
||||
MalType* mal_error;
|
||||
|
||||
} value;
|
||||
};
|
||||
|
||||
struct MalClosure_s {
|
||||
|
||||
Env* env;
|
||||
MalType* parameters;
|
||||
MalType* more_symbol;
|
||||
MalType* definition;
|
||||
|
||||
};
|
||||
|
||||
MalType* make_symbol(char* value);
|
||||
MalType* make_integer(long value);
|
||||
MalType* make_float(double value);
|
||||
MalType* make_keyword(char* value);
|
||||
MalType* make_string(char* value);
|
||||
MalType* make_list(list value);
|
||||
MalType* make_vector(list value);
|
||||
MalType* make_hashmap(list value);
|
||||
MalType* make_true();
|
||||
MalType* make_false();
|
||||
MalType* make_nil();
|
||||
MalType* make_atom(MalType* value);
|
||||
MalType* make_error(char* msg);
|
||||
MalType* make_error_fmt(char* fmt, ...);
|
||||
MalType* wrap_error(MalType* value);
|
||||
MalType* make_function(MalType*(*fn)(list args));
|
||||
MalType* make_closure(Env* env, MalType* parameters, MalType* definition, MalType* more_symbol);
|
||||
MalType* copy_type(MalType* value);
|
||||
|
||||
int is_sequential(MalType* val);
|
||||
int is_self_evaluating(MalType* val);
|
||||
int is_list(MalType* val);
|
||||
int is_vector(MalType* val);
|
||||
int is_hashmap(MalType* val);
|
||||
int is_nil(MalType* val);
|
||||
int is_string(MalType* val);
|
||||
int is_integer(MalType* val);
|
||||
int is_float(MalType* val);
|
||||
int is_number(MalType* val);
|
||||
int is_true(MalType* val);
|
||||
int is_false(MalType* val);
|
||||
int is_symbol(MalType* val);
|
||||
int is_keyword(MalType* val);
|
||||
int is_atom(MalType* val);
|
||||
int is_error(MalType* val);
|
||||
int is_callable(MalType* val);
|
||||
int is_function(MalType* val);
|
||||
int is_closure(MalType* val);
|
||||
int is_macro(MalType* val);
|
||||
|
||||
#endif
|
Loading…
Reference in New Issue
Block a user