felix
/
slime
1
0
Fork 0
Código Incidencias 0 Pull Requests 0 Lanzamientos 0 Wiki Actividad
Explorar el Código

everything broke, we'll make cMacros now

master
fumfar hiwi hace 6 años
padre
b83a479533
commit
f12994cbfe
Se han modificado 11 ficheros con 680 adiciones y 682 borrados
Dividir vista
Opciones de diferencias
Mostrar estadísticas Descargar archivo de parche Descargar archivo de diferencias
  1. +192
    -193
      bin/tests/sicp.slime
  2. +2
    -2
      build.bat
  3. +390
    -402
      src/eval.cpp
  4. +3
    -1
      src/gc.cpp
  5. +4
    -1
      src/globals.cpp
  6. +14
    -9
      src/io.cpp
  7. +0
    -1
      src/libslime.cpp
  8. +0
    -7
      src/lisp_object.cpp
  9. +14
    -12
      src/memory.cpp
  10. +21
    -14
      src/structs.cpp
  11. +40
    -40
      src/testing.cpp

+ 192
- 193
bin/tests/sicp.slime Ver fichero

@@ -1,9 +1,9 @@
(define (abs x)
(cond ((< x 0) (- x))
(else x)))
;; (define (abs x)
;; (cond ((< x 0) (- x))
;; (else x)))

(assert (= (abs 1) 1))
(assert (= (abs (- 2)) 2))
;; (assert (= (abs 1) 1))
;; (assert (= (abs (- 2)) 2))


(define (abs x)
@@ -11,113 +11,113 @@
(- x)
x))

(assert (= (abs 12) 12))
(assert (= (abs (- 32)) 32))
;; (assert (= (abs 12) 12))
;; (assert (= (abs (- 32)) 32))


(define (>= x y)
(or (> x y)
(= x y)))
;; (define (>= x y)
;; (or (> x y)
;; (= x y)))

(assert (>= 2 2))
(assert (>= 3 2))
(assert (not (>= 1 2)))
(assert (not (>= 12 44)))
;; (assert (>= 2 2))
;; (assert (>= 3 2))
;; (assert (not (>= 1 2)))
;; (assert (not (>= 12 44)))


(define (>= x y)
(not (< x y)))
;; (define (>= x y)
;; (not (< x y)))

(assert (>= 2 2))
(assert (>= 3 2))
(assert (not (>= 1 2)))
(assert (not (>= 12 44)))
;; (assert (>= 2 2))
;; (assert (>= 3 2))
;; (assert (not (>= 1 2)))
;; (assert (not (>= 12 44)))


(define (a-plus-abs-b a b)
((if (> b 0) + -) a b))
;; (define (a-plus-abs-b a b)
;; ((if (> b 0) + -) a b))

(assert (= (a-plus-abs-b 1 2) 3))
(assert (= (a-plus-abs-b 1 -2) 3))
;; (assert (= (a-plus-abs-b 1 2) 3))
;; (assert (= (a-plus-abs-b 1 -2) 3))

(define (square x) (* x x))
(define (cube x) (* x x x))

(assert (= ((lambda (x y z)
(+ x y (square z)))
1 2 3)
12))
;; (assert (= ((lambda (x y z)
;; (+ x y (square z)))
;; 1 2 3)
;; 12))

;;; --------------------
;;; newtons method
;;; --------------------
;; ;;; --------------------
;; ;;; newtons method
;; ;;; --------------------

(define tolerance 0.001)
;; (define tolerance 0.001)

(define (square x)
(* x x))
;; (define (square x)
;; (* x x))

(define (average x y)
(/ (+ x y) 2))

(define (improve guess x)
(average guess (/ x guess)))
;; (define (improve guess x)
;; (average guess (/ x guess)))

(define (good-enough? guess x)
(< (abs (- (square guess) x)) tolerance))
;; (define (good-enough? guess x)
;; (< (abs (- (square guess) x)) tolerance))

(define (sqrt-iter guess x)
(if (good-enough? guess x)
guess
(sqrt-iter (improve guess x) x)))
;; (define (sqrt-iter guess x)
;; (if (good-enough? guess x)
;; guess
;; (sqrt-iter (improve guess x) x)))

(define (sqrt x)
(sqrt-iter 1.0 x))
;; (define (sqrt x)
;; (sqrt-iter 1.0 x))

(define (sqrt2 x)
(define (good-enough? guess x)
(< (abs (- (square guess) x)) 0.001))
;; (define (sqrt2 x)
;; (define (good-enough? guess x)
;; (< (abs (- (square guess) x)) 0.001))

(define (improve guess x)
(average guess (/ x guess)))
;; (define (improve guess x)
;; (average guess (/ x guess)))

(define (sqrt-iter guess x)
(if (good-enough? guess x)
guess
(sqrt-iter (improve guess x) x)))
;; (define (sqrt-iter guess x)
;; (if (good-enough? guess x)
;; guess
;; (sqrt-iter (improve guess x) x)))

(sqrt-iter 1.0 x))
;; (sqrt-iter 1.0 x))

(define (sqrt3 x)
(define (good-enough? guess)
(< (abs (- (square guess) x)) 0.001))
;; (define (sqrt3 x)
;; (define (good-enough? guess)
;; (< (abs (- (square guess) x)) 0.001))

(define (improve guess)
(average guess (/ x guess)))
;; (define (improve guess)
;; (average guess (/ x guess)))

(define (sqrt-iter guess)
(if (good-enough? guess)
guess
(sqrt-iter (improve guess))))
;; (define (sqrt-iter guess)
;; (if (good-enough? guess)
;; guess
;; (sqrt-iter (improve guess))))

(sqrt-iter 1.0))
;; (sqrt-iter 1.0))

(assert (< (abs (- 3 (sqrt 9))) tolerance))
(assert (< (abs (- 4 (sqrt 16))) tolerance))
(assert (not (< (abs (- 4 (sqrt 15))) tolerance)))
;; (assert (< (abs (- 3 (sqrt 9))) tolerance))
;; (assert (< (abs (- 4 (sqrt 16))) tolerance))
;; (assert (not (< (abs (- 4 (sqrt 15))) tolerance)))

(assert (< (abs (- 3 (sqrt2 9))) tolerance))
(assert (< (abs (- 4 (sqrt2 16))) tolerance))
(assert (not (< (abs (- 4 (sqrt2 15))) tolerance)))
;; (assert (< (abs (- 3 (sqrt2 9))) tolerance))
;; (assert (< (abs (- 4 (sqrt2 16))) tolerance))
;; (assert (not (< (abs (- 4 (sqrt2 15))) tolerance)))

(assert (< (abs (- 3 (sqrt3 9))) tolerance))
(assert (< (abs (- 4 (sqrt3 16))) tolerance))
(assert (not (< (abs (- 4 (sqrt3 15))) tolerance)))
;; (assert (< (abs (- 3 (sqrt3 9))) tolerance))
;; (assert (< (abs (- 4 (sqrt3 16))) tolerance))
;; (assert (not (< (abs (- 4 (sqrt3 15))) tolerance)))


;;; -----------------
;;; factorial
;;; -----------------
;; ;;; -----------------
;; ;;; factorial
;; ;;; -----------------

(define (factorial n)
(if (= n 1)
@@ -158,45 +158,45 @@
(assert (= (A 3 1) 13))


;;; ---------------
;;; Fibonacci
;;; ---------------
;; ;;; ---------------
;; ;;; Fibonacci
;; ;;; ---------------

(define (fib n)
(cond ((= n 0) 0)
((= n 1) 1)
(else (+ (fib (- n 1)) (fib (- n 2))))))
;; (define (fib n)
;; (cond ((= n 0) 0)
;; ((= n 1) 1)
;; (else (+ (fib (- n 1)) (fib (- n 2))))))

(define (fib2 n)
(fib-iter 1 0 n))
;; (define (fib2 n)
;; (fib-iter 1 0 n))

(define (fib-iter a b count)
(if (= count 0)
b
(fib-iter (+ a b) a (- count 1))))
;; (define (fib-iter a b count)
;; (if (= count 0)
;; b
;; (fib-iter (+ a b) a (- count 1))))

(assert (= (fib 2) 1))
(assert (= (fib 3) 2))
(assert (= (fib 4) 3))
(assert (= (fib 5) 5))
(assert (= (fib 6) 8))
;; (assert (= (fib 2) 1))
;; (assert (= (fib 3) 2))
;; (assert (= (fib 4) 3))
;; (assert (= (fib 5) 5))
;; (assert (= (fib 6) 8))

(assert (= (fib2 2) 1))
(assert (= (fib2 3) 2))
(assert (= (fib2 4) 3))
(assert (= (fib2 5) 5))
(assert (= (fib2 6) 8))
;; (assert (= (fib2 2) 1))
;; (assert (= (fib2 3) 2))
;; (assert (= (fib2 4) 3))
;; (assert (= (fib2 5) 5))
;; (assert (= (fib2 6) 8))

;;; ------------------
;;; count change
;;; ------------------
;; ;;; ------------------
;; ;;; count change
;; ;;; ------------------

;; (define (count-change amount)
;; (define (cc amount kinds-of-coins)
;; (cond ((= amount 0) 1)
;; ((or (< amount 0) (= kinds-of-coins 0)) 0)
;; (else (+ (cc amount (- kinds-of-coins 1))
;; (cc (- amount (first-denomination kinds-of-coins)) kinds-of-coins)))))
;; (cc (- amount (first-denomination kinds-of-coins)) kinds-of-coins)))))

;; (define (first-denomination kinds-of-coins)
;; (cond ((= kinds-of-coins 1) 1)
@@ -209,133 +209,132 @@

;; (assert (= (count-change 100) 292))

;;; --------------------
;;; exponentiation
;;; --------------------
;; ;;; --------------------
;; ;;; exponentiation
;; ;;; --------------------

(define (expt b n)
(if (= n 0)
1
(* b (expt b (- n 1)))))
;; (define (expt b n)
;; (if (= n 0)
;; 1
;; (* b (expt b (- n 1)))))

(define (expt2 b n)
(define (expt-iter b counter product)
(if (= counter 0)
product
(expt-iter b (- counter 1) (* b product))))
;; (define (expt2 b n)
;; (define (expt-iter b counter product)
;; (if (= counter 0)
;; product
;; (expt-iter b (- counter 1) (* b product))))

(expt-iter b n 1))
;; (expt-iter b n 1))

(define (fast-expt b n)
(define (even? n)
(= (% n 2) 0))
;; (define (fast-expt b n)
;; (define (even? n)
;; (= (% n 2) 0))

(cond ((= n 0) 1)
((even? n) (square (fast-expt b (/ n 2))))
(else (* b (fast-expt b (- n 1))))))
;; (cond ((= n 0) 1)
;; ((even? n) (square (fast-expt b (/ n 2))))
;; (else (* b (fast-expt b (- n 1))))))

(assert (= (expt 1 2) 1))
(assert (= (expt 2 2) 4))
(assert (= (expt 2 3) 8))
;; (assert (= (expt 1 2) 1))
;; (assert (= (expt 2 2) 4))
;; (assert (= (expt 2 3) 8))

(assert (= (expt2 1 2) 1))
(assert (= (expt2 2 2) 4))
(assert (= (expt2 2 3) 8))
;; (assert (= (expt2 1 2) 1))
;; (assert (= (expt2 2 2) 4))
;; (assert (= (expt2 2 3) 8))

(assert (= (fast-expt 1 2) 1))
(assert (= (fast-expt 2 2) 4))
(assert (= (fast-expt 2 3) 8))
;; (assert (= (fast-expt 1 2) 1))
;; (assert (= (fast-expt 2 2) 4))
;; (assert (= (fast-expt 2 3) 8))

;;; ----------
;;; gcd
;;; ----------
;; ;;; ----------
;; ;;; gcd
;; ;;; ----------

(define (gcd a b)
(if (= b 0)
a
(gcd b (% a b))))
;; (define (gcd a b)
;; (if (= b 0)
;; a
;; (gcd b (% a b))))

(assert (= (gcd 40 6) 2))
(assert (= (gcd 13 4) 1))
;; (assert (= (gcd 40 6) 2))
;; (assert (= (gcd 13 4) 1))


;;; ----------
;;; primes
;;; ----------
;; ;;; ----------
;; ;;; primes
;; ;;; ----------

(define (smallest-divisor n)
(find-divisor n 2))
;; (define (smallest-divisor n)
;; (find-divisor n 2))

(define (find-divisor n test-divisor)
(cond ((> (square test-divisor) n) n)
((divides? test-divisor n) test-divisor)
(else (find-divisor n (+ test-divisor 1)))))
;; (define (find-divisor n test-divisor)
;; (cond ((> (square test-divisor) n) n)
;; ((divides? test-divisor n) test-divisor)
;; (else (find-divisor n (+ test-divisor 1)))))

(define (divides? a b)
(= (% b a) 0))
;; (define (divides? a b)
;; (= (% b a) 0))

(define (prime? n)
(= n (smallest-divisor n)))
;; (define (prime? n)
;; (= n (smallest-divisor n)))

(assert (prime? 13))
(assert (prime? 11))
(assert (not (prime? 12)))
;; (assert (prime? 13))
;; (assert (prime? 11))
;; (assert (not (prime? 12)))


;;; ----------------------
;;; simple integral
;;; ----------------------

(define (sum term a next b)
(if (> a b)
0
(+ (term a) (sum term (next a) next b))))
;; (define (sum term a next b)
;; (if (> a b)
;; 0
;; (+ (term a) (sum term (next a) next b))))

(define (integral f a b dx)
(define (add-dx x) (+ x dx))
(* (sum f (+ a (/ dx 2.0)) add-dx b) dx))
;; (define (integral f a b dx)
;; (define (add-dx x) (+ x dx))
;; (* (sum f (+ a (/ dx 2.0)) add-dx b) dx))

(define (pi-sum a b)
(define (pi-term x) (/ 1.0 (* x (+ x 2))))
(define (pi-next x) (+ x 4))
(sum pi-term a pi-next b))
;; (define (pi-sum a b)
;; (define (pi-term x) (/ 1.0 (* x (+ x 2))))
;; (define (pi-next x) (+ x 4))
;; (sum pi-term a pi-next b))

(assert (< (abs (- (* 8 (pi-sum 1 100)) 3.121595)) 0.0001))
(assert (< (abs (- (integral cube 0 1 0.02) 0.249950)) 0.0001))
;; (assert (< (abs (- (* 8 (pi-sum 1 100)) 3.121595)) 0.0001))
;; (assert (< (abs (- (integral cube 0 1 0.02) 0.249950)) 0.0001))


;; ------------------------------------------------------------
;; F(x,y) = x(1 + xy)^2 + y(1 − y) + (1 + xy)(1 − y)
;; ------------------------------------------------------------

(define (f x y)
(let ((a (+ 1 (* x y)))
(b (- 1 y)))
(+ (* x (square a))
(* y b)
(* a b))))

(assert (= (f 0 0) 1))
(assert (= (f 1 1) 4))
;; (define (f x y)
;; (let ((a (+ 1 (* x y)))
;; (b (- 1 y)))
;; (+ (* x (square a))
;; (* y b)
;; (* a b))))

;; (assert (= (f 0 0) 1))
;; (assert (= (f 1 1) 4))

;;; ---------------
;;; find zero
;;; ---------------

(define (positive? x) (< 0 x))
(define (negative? x) (< x 0))
;; ;;; ---------------
;; ;;; find zero
;; ;;; ---------------

(define (search f neg-point pos-point)
(let ((midpoint (average neg-point pos-point)))
(if (close-enough? neg-point pos-point)
midpoint
(let ((test-value (f midpoint)))
(cond ((positive? test-value) (search f neg-point midpoint))
((negative? test-value) (search f midpoint pos-point))
(else midpoint))))))
;; (define (positive? x) (< 0 x))
;; (define (negative? x) (< x 0))

(define (close-enough? x y) (< (abs (- x y)) 0.001))
;; (define (search f neg-point pos-point)
;; (let ((midpoint (average neg-point pos-point)))
;; (if (close-enough? neg-point pos-point)
;; midpoint
;; (let ((test-value (f midpoint)))
;; (cond ((positive? test-value) (search f neg-point midpoint))
;; ((negative? test-value) (search f midpoint pos-point))
;; (else midpoint))))))

(assert (close-enough? (search (lambda (x) (- 1 (square x))) -3 3) -1))
;; (define (close-enough? x y) (< (abs (- x y)) 0.001))

;; (assert (close-enough? (search (lambda (x) (- 1 (square x))) -3 3) -1))

+ 2
- 2
build.bat Ver fichero

@@ -7,7 +7,7 @@ set exeName=slime.exe
taskkill /F /IM %exeName% > NUL 2> NUL

echo ---------- Compiling ----------
call timecmd cl ^
call cl ^
../src/main.cpp^
/I../3rd/ ^
/D_PROFILING /D_DEBUG ^
@@ -25,7 +25,7 @@ if %errorlevel% == 0 (
echo.
echo ---- Running Tests ----
echo.
call timecmd slime.exe --run-tests
call slime.exe --run-tests
) else (
echo.
echo Fuckin' ell


+ 390
- 402
src/eval.cpp Ver fichero

@@ -10,22 +10,14 @@ namespace Slime {
{
profile_this();

bool is_c_function = Memory::get_type(function) == Lisp_Object_Type::CFunction;
Environment* new_env;
Arguments* arg_spec;
bool is_c_function = function->value.function->is_c;
Environment* new_env = Memory::create_child_environment(function->value.function->parent_environment);
Arguments* arg_spec = &function->value.function->args;

// NOTE(Felix): Step 1.
// - setting the parent environment
// - setting the arg_spec
// - potentially evaluating the arguments
if (is_c_function) {
new_env = Memory::create_child_environment(get_root_environment());
arg_spec = &function->value.cFunction->args;
} else {
new_env = Memory::create_child_environment(function->value.function->parent_environment);
arg_spec = &function->value.function->args;
}

if (arg_count == 0) {
return new_env;
}
@@ -145,7 +137,8 @@ namespace Slime {
}

// if not set it and then add it to the array list
try_void sym = Memory::get_symbol(next_arg->value.symbol);
Lisp_Object* key = next_arg;
try_void sym = Memory::get_symbol(key->value.symbol);
next_arg = cs->data[++arg_start];
--arg_count;

@@ -157,7 +150,7 @@ namespace Slime {
Memory::copy_lisp_object_except_pairs(next_arg));
}

read_in_keywords.append(next_arg);
read_in_keywords.append(key);
++read_obligatory_keywords_count;

// overstep both for next one
@@ -243,256 +236,257 @@ namespace Slime {

return new_env;
}
proc create_extended_environment_for_function_application(
Lisp_Object* unevaluated_arguments,
Lisp_Object* function,
bool should_evaluate) -> Environment*
{
profile_this();
bool is_c_function = Memory::get_type(function) == Lisp_Object_Type::CFunction;
Environment* new_env;
Lisp_Object* arguments = unevaluated_arguments;
Arguments* arg_spec;

// NOTE(Felix): Step 1.
// - setting the parent environment
// - setting the arg_spec
// - potentially evaluating the arguments
if (is_c_function) {
new_env = Memory::create_child_environment(get_root_environment());
arg_spec = &function->value.cFunction->args;
} else {
new_env = Memory::create_child_environment(function->value.function->parent_environment);
arg_spec = &function->value.function->args;
}
if (should_evaluate) {
try arguments = eval_arguments(arguments);
}

// NOTE(Felix): Even though we will return the environment at the
// end, for defining symbols here for the parameters, it has to be
// on the envi stack.
push_environment(new_env);
defer {
pop_environment();
};


// NOTE(Felix): Step 2.
// Reading the argument spec and fill in the environment
// for the function call

Lisp_Object* sym, *val; // used as temp storage to use `try`
Array_List<Lisp_Object*> read_in_keywords;
read_in_keywords.alloc();
defer {
read_in_keywords.dealloc();
};
int obligatory_keywords_count = 0;
int read_obligatory_keywords_count = 0;

proc read_positional_args = [&]() -> void {
for (int i = 0; i < arg_spec->positional.symbols.next_index; ++i) {
if (Memory::get_type(arguments) != Lisp_Object_Type::Pair) {
create_parsing_error("Wrong number of arguments.");
return;
}
// NOTE(Felix): We have to copy all the arguments,
// otherwise we change the program code. XXX(Felix): T C
// functions we pass by reference...
sym = arg_spec->positional.symbols.data[i];
if (is_c_function) {
define_symbol(sym, arguments->value.pair.first);
} else {
define_symbol(
sym,
Memory::copy_lisp_object_except_pairs(arguments->value.pair.first));
}

arguments = arguments->value.pair.rest;
}
};

proc read_keyword_args = [&]() -> void {
// keyword arguments: use all given ones and keep track of the
// added ones (array list), if end of parameters in encountered or
// something that is not a keyword is encountered or a keyword
// that is not recognized is encoutered, jump out of the loop.

if (arguments == Memory::nil)
return;

// find out how many keyword args we /have/ to read
for (int i = 0; i < arg_spec->keyword.values.next_index; ++i) {
if (arg_spec->keyword.values.data[i] == nullptr)
++obligatory_keywords_count;
else
break;
}


while (Memory::get_type(arguments->value.pair.first) == Lisp_Object_Type::Keyword) {
// check if this one is even an accepted keyword
bool accepted = false;
for (int i = 0; i < arg_spec->keyword.values.next_index; ++i) {
if (arguments->value.pair.first == arg_spec->keyword.keywords.data[i])
{
accepted = true;
break;
}
}
if (!accepted) {
// NOTE(Felix): if we are actually done with all the
// necessary keywords then we have to count the rest
// as :rest here, instead od always creating an error
// (special case with default variables)
if (read_obligatory_keywords_count == obligatory_keywords_count)
return;
create_generic_error(
"The function does not take the keyword argument ':%s'\n"
"and not all required keyword arguments have been read\n"
"in to potentially count it as the rest argument.",
&(arguments->value.pair.first->value.symbol->data));
return;
}

// check if it was already read in
for (int i = 0; i < read_in_keywords.next_index; ++i) {
if (arguments->value.pair.first == read_in_keywords.data[i])
{
// NOTE(Felix): if we are actually done with all the
// necessary keywords then we have to count the rest
// as :rest here, instead od always creating an error
// (special case with default variables)
if (read_obligatory_keywords_count == obligatory_keywords_count)
return;
create_generic_error(
"The function already read the keyword argument ':%s'",
&(arguments->value.pair.first->value.symbol->data));
return;
}
}

// okay so we found a keyword that has to be read in and was
// not already read in, is there a next element to actually
// set it to?
if (Memory::get_type(arguments->value.pair.rest) != Lisp_Object_Type::Pair) {
create_generic_error(
"Attempting to set the keyword argument ':%s', but no value was supplied.",
&(arguments->value.pair.first->value.symbol->data));
return;
}

// if not set it and then add it to the array list
try_void sym = Memory::get_symbol(arguments->value.pair.first->value.symbol);
// NOTE(Felix): It seems we do not need to evaluate the argument here...
if (is_c_function) {
try_void define_symbol(sym, arguments->value.pair.rest->value.pair.first);
} else {
try_void define_symbol(
sym,
Memory::copy_lisp_object_except_pairs(arguments->value.pair.rest->value.pair.first));
}

read_in_keywords.append(arguments->value.pair.first);
++read_obligatory_keywords_count;

// overstep both for next one
arguments = arguments->value.pair.rest->value.pair.rest;

if (arguments == Memory::nil) {
break;
}
}
};

proc check_keyword_args = [&]() -> void {
// check if all necessary keywords have been read in
for (int i = 0; i < arg_spec->keyword.values.next_index; ++i) {
auto defined_keyword = arg_spec->keyword.keywords.data[i];
bool was_set = false;
for (int j = 0; j < read_in_keywords.next_index; ++j) {
if (read_in_keywords.data[j] == defined_keyword) {
was_set = true;
break;
}
}
if (arg_spec->keyword.values.data[i] == nullptr) {
// if this one does not have a default value
if (!was_set) {
create_generic_error(
"There was no value supplied for the required "
"keyword argument ':%s'.",
&defined_keyword->value.symbol->data);
return;
}
} else {
// this one does have a default value, lets see if we have
// to use it or if the user supplied his own
if (!was_set) {
try_void sym = Memory::get_symbol(defined_keyword->value.symbol);
if (is_c_function) {
try_void val = arg_spec->keyword.values.data[i];
} else {
try_void val = Memory::copy_lisp_object_except_pairs(arg_spec->keyword.values.data[i]);
}
define_symbol(sym, val);
}
}
}
};

proc read_rest_arg = [&]() -> void {
if (arguments == Memory::nil) {
if (arg_spec->rest) {
define_symbol(arg_spec->rest, Memory::nil);
}
} else {
if (arg_spec->rest) {
define_symbol(
arg_spec->rest,
// NOTE(Felix): arguments will be a list, and I THINK
// we do not need to copy it...
arguments);
} else {
// rest was not declared but additional arguments were found
create_generic_error(
"A rest argument was not declared "
"but the function was called with additional arguments.");
return;
}
}
};

try read_positional_args();
try read_keyword_args();
try check_keyword_args();
try read_rest_arg();

return new_env;
}

proc apply_arguments_to_function(Lisp_Object* arguments, Lisp_Object* function, bool should_evaluate_args) -> Lisp_Object* {
profile_this();
Environment* new_env;
Lisp_Object* result;

try new_env = create_extended_environment_for_function_application(arguments, function, should_evaluate_args);
push_environment(new_env);
defer {
pop_environment();
};


if (Memory::get_type(function) == Lisp_Object_Type::CFunction)
// if c function:
try result = function->value.cFunction->body();
else
// if lisp function
try result = eval_expr(function->value.function->body);

return result;
}
// proc create_extended_environment_for_function_application(
// Lisp_Object* unevaluated_arguments,
// Lisp_Object* function,
// bool should_evaluate) -> Environment*
// {
// profile_this();
// bool is_c_function = Memory::get_type(function) == Lisp_Object_Type::CFunction;
// Environment* new_env;
// Lisp_Object* arguments = unevaluated_arguments;
// Arguments* arg_spec;

// // NOTE(Felix): Step 1.
// // - setting the parent environment
// // - setting the arg_spec
// // - potentially evaluating the arguments
// if (is_c_function) {
// new_env = Memory::create_child_environment(get_root_environment());
// arg_spec = &function->value.cFunction->args;
// } else {
// new_env = Memory::create_child_environment(function->value.function->parent_environment);
// arg_spec = &function->value.function->args;
// }
// if (should_evaluate) {
// try arguments = eval_arguments(arguments);
// }

// // NOTE(Felix): Even though we will return the environment at the
// // end, for defining symbols here for the parameters, it has to be
// // on the envi stack.
// push_environment(new_env);
// defer {
// pop_environment();
// };


// // NOTE(Felix): Step 2.
// // Reading the argument spec and fill in the environment
// // for the function call

// Lisp_Object* sym, *val; // used as temp storage to use `try`
// Array_List<Lisp_Object*> read_in_keywords;
// read_in_keywords.alloc();
// defer {
// read_in_keywords.dealloc();
// };
// int obligatory_keywords_count = 0;
// int read_obligatory_keywords_count = 0;

// proc read_positional_args = [&]() -> void {
// for (int i = 0; i < arg_spec->positional.symbols.next_index; ++i) {
// if (Memory::get_type(arguments) != Lisp_Object_Type::Pair) {
// create_parsing_error("Wrong number of arguments.");
// return;
// }
// // NOTE(Felix): We have to copy all the arguments,
// // otherwise we change the program code. XXX(Felix): T C
// // functions we pass by reference...
// sym = arg_spec->positional.symbols.data[i];
// if (is_c_function) {
// define_symbol(sym, arguments->value.pair.first);
// } else {
// define_symbol(
// sym,
// Memory::copy_lisp_object_except_pairs(arguments->value.pair.first));
// }

// arguments = arguments->value.pair.rest;
// }
// };

// proc read_keyword_args = [&]() -> void {
// // keyword arguments: use all given ones and keep track of the
// // added ones (array list), if end of parameters in encountered or
// // something that is not a keyword is encountered or a keyword
// // that is not recognized is encoutered, jump out of the loop.

// if (arguments == Memory::nil)
// return;

// // find out how many keyword args we /have/ to read
// for (int i = 0; i < arg_spec->keyword.values.next_index; ++i) {
// if (arg_spec->keyword.values.data[i] == nullptr)
// ++obligatory_keywords_count;
// else
// break;
// }


// while (Memory::get_type(arguments->value.pair.first) == Lisp_Object_Type::Keyword) {
// // check if this one is even an accepted keyword
// bool accepted = false;
// for (int i = 0; i < arg_spec->keyword.values.next_index; ++i) {
// if (arguments->value.pair.first == arg_spec->keyword.keywords.data[i])
// {
// accepted = true;
// break;
// }
// }
// if (!accepted) {
// // NOTE(Felix): if we are actually done with all the
// // necessary keywords then we have to count the rest
// // as :rest here, instead od always creating an error
// // (special case with default variables)
// if (read_obligatory_keywords_count == obligatory_keywords_count)
// return;
// create_generic_error(
// "The function does not take the keyword argument ':%s'\n"
// "and not all required keyword arguments have been read\n"
// "in to potentially count it as the rest argument.",
// &(arguments->value.pair.first->value.symbol->data));
// return;
// }

// // check if it was already read in
// for (int i = 0; i < read_in_keywords.next_index; ++i) {
// if (arguments->value.pair.first == read_in_keywords.data[i])
// {
// // NOTE(Felix): if we are actually done with all the
// // necessary keywords then we have to count the rest
// // as :rest here, instead od always creating an error
// // (special case with default variables)
// if (read_obligatory_keywords_count == obligatory_keywords_count)
// return;
// create_generic_error(
// "The function already read the keyword argument ':%s'",
// &(arguments->value.pair.first->value.symbol->data));
// return;
// }
// }

// // okay so we found a keyword that has to be read in and was
// // not already read in, is there a next element to actually
// // set it to?
// if (Memory::get_type(arguments->value.pair.rest) != Lisp_Object_Type::Pair) {
// create_generic_error(
// "Attempting to set the keyword argument ':%s', but no value was supplied.",
// &(arguments->value.pair.first->value.symbol->data));
// return;
// }

// // if not set it and then add it to the array list
// try_void sym = Memory::get_symbol(arguments->value.pair.first->value.symbol);
// // NOTE(Felix): It seems we do not need to evaluate the argument here...
// if (is_c_function) {
// try_void define_symbol(sym, arguments->value.pair.rest->value.pair.first);
// } else {
// try_void define_symbol(
// sym,
// Memory::copy_lisp_object_except_pairs(arguments->value.pair.rest->value.pair.first));
// }

// read_in_keywords.append(arguments->value.pair.first);
// ++read_obligatory_keywords_count;

// // overstep both for next one
// arguments = arguments->value.pair.rest->value.pair.rest;

// if (arguments == Memory::nil) {
// break;
// }
// }
// };

// proc check_keyword_args = [&]() -> void {
// // check if all necessary keywords have been read in
// for (int i = 0; i < arg_spec->keyword.values.next_index; ++i) {
// auto defined_keyword = arg_spec->keyword.keywords.data[i];
// bool was_set = false;
// for (int j = 0; j < read_in_keywords.next_index; ++j) {
// if (read_in_keywords.data[j] == defined_keyword) {
// was_set = true;
// break;
// }
// }
// if (arg_spec->keyword.values.data[i] == nullptr) {
// // if this one does not have a default value
// if (!was_set) {
// create_generic_error(
// "There was no value supplied for the required "
// "keyword argument ':%s'.",
// &defined_keyword->value.symbol->data);
// return;
// }
// } else {
// // this one does have a default value, lets see if we have
// // to use it or if the user supplied his own
// if (!was_set) {
// try_void sym = Memory::get_symbol(defined_keyword->value.symbol);
// if (is_c_function) {
// try_void val = arg_spec->keyword.values.data[i];
// } else {
// try_void val = Memory::copy_lisp_object_except_pairs(arg_spec->keyword.values.data[i]);
// }
// define_symbol(sym, val);
// }
// }
// }
// };

// proc read_rest_arg = [&]() -> void {
// if (arguments == Memory::nil) {
// if (arg_spec->rest) {
// define_symbol(arg_spec->rest, Memory::nil);
// }
// } else {
// if (arg_spec->rest) {
// define_symbol(
// arg_spec->rest,
// // NOTE(Felix): arguments will be a list, and I THINK
// // we do not need to copy it...
// arguments);
// } else {
// // rest was not declared but additional arguments were found
// create_generic_error(
// "A rest argument was not declared "
// "but the function was called with additional arguments.");
// return;
// }
// }
// };

// try read_positional_args();
// try read_keyword_args();
// try check_keyword_args();
// try read_rest_arg();

// return new_env;
// }

// proc apply_arguments_to_function(Lisp_Object* arguments, Lisp_Object* function, bool should_evaluate_args) -> Lisp_Object* {
// profile_this();
// Environment* new_env;
// Lisp_Object* result;

// try new_env = create_extended_environment_for_function_application(arguments, function, should_evaluate_args);
// push_environment(new_env);
// defer {
// pop_environment();
// };


// if (Memory::get_type(function) == Lisp_Object_Type::CFunction)
// // if c function:
// try result = function->value.cFunction->body();
// else
// // if lisp function
// try result = eval_expr(function->value.function->body);

// return result;
// }

proc create_arguments_from_lambda_list_and_inject(Lisp_Object* arguments, Lisp_Object* function) -> void {
/* NOTE This parses the argument specification of funcitons
@@ -500,12 +494,7 @@ namespace Slime {
* positional_arguments, keyword_arguments and rest_argument
* and filling it in
*/
Arguments* result;
if (Memory::get_type(function) == Lisp_Object_Type::CFunction) {
result = &function->value.cFunction->args;
} else {
result = &function->value.function->args;
}
Arguments* result = &function->value.function->args;;

// first init the fields
result->rest = nullptr;
@@ -604,41 +593,41 @@ namespace Slime {
return nullptr;
}

proc eval_arguments(Lisp_Object* arguments) -> Lisp_Object* {
profile_this();
// int my_out_arguments_length = 0;
if (arguments == Memory::nil) {
// *(out_arguments_length) = 0;
return arguments;
}
Lisp_Object* evaluated_arguments;
try evaluated_arguments = Memory::create_lisp_object_pair(Memory::nil, Memory::nil);
Lisp_Object* evaluated_arguments_head = evaluated_arguments;
Lisp_Object* current_head = arguments;
while (Memory::get_type(current_head) == Lisp_Object_Type::Pair) {
try evaluated_arguments_head->value.pair.first = eval_expr(current_head->value.pair.first);
evaluated_arguments_head->value.pair.first->sourceCodeLocation =
copy_scl(current_head->value.pair.first->sourceCodeLocation);
current_head = current_head->value.pair.rest;
if (Memory::get_type(current_head) == Lisp_Object_Type::Pair) {
try evaluated_arguments_head->value.pair.rest = Memory::create_lisp_object_pair(Memory::nil, Memory::nil);
evaluated_arguments_head = evaluated_arguments_head->value.pair.rest;
} else if (current_head == Memory::nil) {
evaluated_arguments_head->value.pair.rest = current_head;
} else {
create_parsing_error("Attempting to evaluate ill formed argument list.");
return nullptr;
}
// ++my_out_arguments_length;
}
// *(out_arguments_length) = my_out_arguments_length;
return evaluated_arguments;
}
// proc eval_arguments(Lisp_Object* arguments) -> Lisp_Object* {
// profile_this();
// // int my_out_arguments_length = 0;
// if (arguments == Memory::nil) {
// // *(out_arguments_length) = 0;
// return arguments;
// }
// Lisp_Object* evaluated_arguments;
// try evaluated_arguments = Memory::create_lisp_object_pair(Memory::nil, Memory::nil);
// Lisp_Object* evaluated_arguments_head = evaluated_arguments;
// Lisp_Object* current_head = arguments;
// while (Memory::get_type(current_head) == Lisp_Object_Type::Pair) {
// try evaluated_arguments_head->value.pair.first = eval_expr(current_head->value.pair.first);
// evaluated_arguments_head->value.pair.first->sourceCodeLocation =
// copy_scl(current_head->value.pair.first->sourceCodeLocation);
// current_head = current_head->value.pair.rest;
// if (Memory::get_type(current_head) == Lisp_Object_Type::Pair) {
// try evaluated_arguments_head->value.pair.rest = Memory::create_lisp_object_pair(Memory::nil, Memory::nil);
// evaluated_arguments_head = evaluated_arguments_head->value.pair.rest;
// } else if (current_head == Memory::nil) {
// evaluated_arguments_head->value.pair.rest = current_head;
// } else {
// create_parsing_error("Attempting to evaluate ill formed argument list.");
// return nullptr;
// }
// // ++my_out_arguments_length;
// }
// // *(out_arguments_length) = my_out_arguments_length;
// return evaluated_arguments;
// }

proc pause() {
printf("\n-----------------------\n"
@@ -654,6 +643,7 @@ namespace Slime {
}

proc nrc_eval(Lisp_Object* expr) -> Lisp_Object* {
using namespace Globals::Current_Execution;
enum struct Action {
Eval,
Step,
@@ -664,17 +654,12 @@ namespace Slime {
Pop_Environment
};

Array_List<Lisp_Object*> cs;
Array_List<Lisp_Object*> pcs;
Array_List<Action> nas;
Array_List<int> ams;

cs.alloc();
pcs.alloc();
nas.alloc();
ams.alloc();

proc debug_step = [&] {
return;
// printf("%d\n", cs.next_index);
printf("cs:\n ");
for (auto lo : cs) {
print(lo, true);
@@ -705,7 +690,7 @@ namespace Slime {
for (auto am : ams) {
printf("%d\n ", am);
}
pause();
// pause();
};

proc push_pc_on_cs = [&] {
@@ -772,10 +757,10 @@ namespace Slime {
fflush(stdout);
try_void assert_type(definee->value.pair.first, Lisp_Object_Type::Symbol);
Lisp_Object* func;
try_void func = Memory::create_lisp_object_function(Function_Type::Lambda);
try_void func = Memory::create_lisp_object_function(Lisp_Function_Type::Lambda);
func->value.function->parent_environment = get_current_environment();
create_arguments_from_lambda_list_and_inject(definee->value.pair.rest, func);
func->value.function->body = maybe_wrap_body_in_begin(thing_cons);
func->value.function->body.lisp_body = maybe_wrap_body_in_begin(thing_cons);
define_symbol(definee->value.pair.first, func);
cs.append(Memory::t);
} break;
@@ -808,7 +793,7 @@ namespace Slime {
Action current_action;
Lisp_Object* pc;
while (nas.next_index > 0) {
// debug_step();
debug_step();

current_action = nas.data[--nas.next_index];
switch (current_action) {
@@ -843,26 +828,29 @@ namespace Slime {

Lisp_Object_Type type = Memory::get_type(pc);
switch (type) {
case Lisp_Object_Type::CFunction: {
if (pc->value.cFunction->is_special_form) {
if (pc == Memory::_if) try handle_if();
else if (pc == Memory::_begin) try handle_begin();
else if (pc == Memory::_define) try handle_define();
else {
push_pc_on_cs();
case Lisp_Object_Type::Function: {
if(pc->value.function->is_c) {
if (pc->value.function->type.c_function_type ==
C_Function_Type::cMacro)
{
if (pc == Memory::_if) try handle_if();
else if (pc == Memory::_begin) try handle_begin();
else if (pc == Memory::_define) try handle_define();
else {
push_pc_on_cs();
nas.append(Action::Step);
}
} else {
nas.append(Action::Step);
}
} else {
nas.append(Action::Step);
}
} break;
case Lisp_Object_Type::Function: {
if (pc->value.function->type == Function_Type::Macro) {
push_pc_on_cs();
nas.append(Action::Eval);
nas.append(Action::Step);
} else {
nas.append(Action::Step);
if (pc->value.function->type == Function_Type::Macro) {
push_pc_on_cs();
nas.append(Action::Eval);
nas.append(Action::Step);
} else {
nas.append(Action::Step);
}
}
} break;
default: {
@@ -931,77 +919,77 @@ namespace Slime {

proc eval_expr(Lisp_Object* node) -> Lisp_Object* {
return nrc_eval(node);
profile_this();
using namespace Globals::Current_Execution;
call_stack.append(node);
defer {
--call_stack.next_index;
};
switch (Memory::get_type(node)) {
case Lisp_Object_Type::Symbol: {
Lisp_Object* value;
try value = lookup_symbol(node, get_current_environment());
return value;
}
case Lisp_Object_Type::Pair: {
Lisp_Object* lispOperator;
if (Memory::get_type(node->value.pair.first) != Lisp_Object_Type::CFunction &&
Memory::get_type(node->value.pair.first) != Lisp_Object_Type::Function)
{
try lispOperator = eval_expr(node->value.pair.first);
} else {
lispOperator = node->value.pair.first;
}
Lisp_Object* arguments = node->value.pair.rest;
// check for c function
if (Memory::get_type(lispOperator) == Lisp_Object_Type::CFunction) {
Lisp_Object* result;
try result = apply_arguments_to_function(
arguments,
lispOperator,
!lispOperator->value.cFunction->is_special_form);
return result;
}
// check for lisp function
if (Memory::get_type(lispOperator) == Lisp_Object_Type::Function) {
// only for lambdas we evaluate the arguments before
// apllying, for the other types, special-lambda and macro
// we do not need.
Lisp_Object* result;
try result = apply_arguments_to_function(
arguments,
lispOperator,
lispOperator->value.function->type == Function_Type::Lambda);
// NOTE(Felix): The parser does not understnad (import ..)
// so it cannot expand imported macros at read time
// (because at read time, they are not imported yet, this
// is done at runtime...). That is why we sometimes have
// stray macros fying around, in that case, we expand them
// and bake them in, so they do not have to be expanded
// later again. We will call this "lazy macro expansion"
if (lispOperator->value.function->type == Function_Type::Macro) {
// bake in the macro expansion:
*node = *Memory::copy_lisp_object(result);
result->sourceCodeLocation = copy_scl(result->sourceCodeLocation);
// eval again because macro
try result = eval_expr(result);
}
return result;
}
create_generic_error("The first element of the pair was not a function but: %s",
Lisp_Object_Type_to_string(Memory::get_type(lispOperator)));
return nullptr;
}
default: return node;
}
// profile_this();
// using namespace Globals::Current_Execution;
// call_stack.append(node);
// defer {
// --call_stack.next_index;
// };
// switch (Memory::get_type(node)) {
// case Lisp_Object_Type::Symbol: {
// Lisp_Object* value;
// try value = lookup_symbol(node, get_current_environment());
// return value;
// }
// case Lisp_Object_Type::Pair: {
// Lisp_Object* lispOperator;
// if (Memory::get_type(node->value.pair.first) != Lisp_Object_Type::CFunction &&
// Memory::get_type(node->value.pair.first) != Lisp_Object_Type::Function)
// {
// try lispOperator = eval_expr(node->value.pair.first);
// } else {
// lispOperator = node->value.pair.first;
// }
// Lisp_Object* arguments = node->value.pair.rest;
// // check for c function
// if (Memory::get_type(lispOperator) == Lisp_Object_Type::CFunction) {
// Lisp_Object* result;
// try result = apply_arguments_to_function(
// arguments,
// lispOperator,
// !lispOperator->value.cFunction->is_special_form);
// return result;
// }
// // check for lisp function
// if (Memory::get_type(lispOperator) == Lisp_Object_Type::Function) {
// // only for lambdas we evaluate the arguments before
// // apllying, for the other types, special-lambda and macro
// // we do not need.
// Lisp_Object* result;
// try result = apply_arguments_to_function(
// arguments,
// lispOperator,
// lispOperator->value.function->type == Function_Type::Lambda);
// // NOTE(Felix): The parser does not understnad (import ..)
// // so it cannot expand imported macros at read time
// // (because at read time, they are not imported yet, this
// // is done at runtime...). That is why we sometimes have
// // stray macros fying around, in that case, we expand them
// // and bake them in, so they do not have to be expanded
// // later again. We will call this "lazy macro expansion"
// if (lispOperator->value.function->type == Function_Type::Macro) {
// // bake in the macro expansion:
// *node = *Memory::copy_lisp_object(result);
// result->sourceCodeLocation = copy_scl(result->sourceCodeLocation);
// // eval again because macro
// try result = eval_expr(result);
// }
// return result;
// }
// create_generic_error("The first element of the pair was not a function but: %s",
// Lisp_Object_Type_to_string(Memory::get_type(lispOperator)));
// return nullptr;
// }
// default: return node;
// }
}

proc is_truthy(Lisp_Object* expression) -> bool {


+ 3
- 1
src/gc.cpp Ver fichero

@@ -47,7 +47,9 @@ namespace Slime::GC {
// for parameter names, as symbols and keywords are never
// garbage collected
maybe_mark(node->value.function->parent_environment);
maybe_mark(node->value.function->body);
if (!node->value.function->is_c) {
maybe_mark(node->value.function->body.lisp_body);
}
// mark the default arguemnt values:
for (auto it : node->value.function->args.keyword.values) {
if (it)


+ 4
- 1
src/globals.cpp Ver fichero

@@ -4,7 +4,10 @@ namespace Slime::Globals {

Array_List<void*> load_path;
namespace Current_Execution {
Array_List<Lisp_Object*> call_stack;
Array_List<Lisp_Object*> cs;
Array_List<Lisp_Object*> pcs;
Array_List<int> ams;
// Array_List<Lisp_Object*> call_stack;
Array_List<Environment*> envi_stack;
}



+ 14
- 9
src/io.cpp Ver fichero

@@ -315,7 +315,6 @@ namespace Slime {
case (Lisp_Object_Type::Keyword): fputs(":", file); // NOTE(Felix): intentionall fallthough
case (Lisp_Object_Type::Symbol): fprintf(file, "%s", Memory::get_c_str(node->value.symbol)); break;
case (Lisp_Object_Type::Continuation): fputs("[continuation]", file); break;
case (Lisp_Object_Type::CFunction): fputs("[C-function]", file); break;
case (Lisp_Object_Type::Pointer): fputs("[pointer]", file); break;
case (Lisp_Object_Type::HashMap): {
for_hash_map (*(node->value.hashMap)) {
@@ -352,14 +351,20 @@ namespace Slime {
fprintf(file, "[%s]", Memory::get_c_str(node->userType->value.symbol));
break;
}
if (node->value.function->type == Function_Type::Lambda)
fputs("[lambda]", file);
// else if (node->value.function->type == Function_Type::Special_Lambda)
// fputs("[special-lambda]", file);
else if (node->value.function->type == Function_Type::Macro)
fputs("[macro]", file);
else
assert(false);
if (node->value.function->is_c) {
switch (node->value.function->type.c_function_type) {
case C_Function_Type::cFunction: {fputs("[c-function]", file);} break;
case C_Function_Type::cSpecial: {fputs("[c-special]", file);} break;
case C_Function_Type::cMacro: {fputs("[c-macro]", file);} break;
default: {fputs("[c-??]", file);}
}
} else {
switch (node->value.function->type.lisp_function_type) {
case Lisp_Function_Type::Lambda: {fputs("[lambda]", file);} break;
case Lisp_Function_Type::Macro: {fputs("[macro]", file);} break;
default: {fputs("[??]", file);}
}
}
} break;
case (Lisp_Object_Type::Pair): {
Lisp_Object* head = node;


+ 0
- 1
src/libslime.cpp Ver fichero

@@ -76,7 +76,6 @@ unsigned int hm_hash(Slime::Lisp_Object* obj) {
switch (Memory::get_type(obj)) {
// hash from adress: if two objects of these types have
// different addresses, they are different
case Lisp_Object_Type::CFunction:
case Lisp_Object_Type::Function:
case Lisp_Object_Type::Symbol:
case Lisp_Object_Type::Keyword:


+ 0
- 7
src/lisp_object.cpp Ver fichero

@@ -19,7 +19,6 @@ namespace Slime {
case(Lisp_Object_Type::Symbol): return "symbol";
case(Lisp_Object_Type::Keyword): return "keyword";
case(Lisp_Object_Type::Function): return "function";
case(Lisp_Object_Type::CFunction): return "C-function";
case(Lisp_Object_Type::Continuation): return "continuation";
case(Lisp_Object_Type::Pair): return "pair";
case(Lisp_Object_Type::Vector): return "vector";
@@ -37,12 +36,6 @@ namespace Slime {
case Lisp_Object_Type::HashMap: {
delete this->value.hashMap;
} break;
case Lisp_Object_Type::CFunction: {
this->value.cFunction->args.positional.symbols.dealloc();
this->value.cFunction->args.keyword.keywords.dealloc();
this->value.cFunction->args.keyword.values.dealloc();
free(this->value.cFunction);
} break;
case Lisp_Object_Type::Function:{
this->value.function->args.positional.symbols.dealloc();
this->value.function->args.keyword.keywords.dealloc();


+ 14
- 12
src/memory.cpp Ver fichero

@@ -176,8 +176,11 @@ namespace Slime::Memory {
char* exe_path = get_exe_dir();
// don't free exe path because it will be used until end of time
Globals::load_path.alloc();
Globals::Current_Execution::call_stack.alloc();
// Globals::Current_Execution::call_stack.alloc();
Globals::Current_Execution::envi_stack.alloc();
Globals::Current_Execution::cs.alloc();
Globals::Current_Execution::pcs.alloc();
Globals::Current_Execution::ams.alloc();

add_to_load_path(exe_path);
add_to_load_path("../bin/");
@@ -424,19 +427,19 @@ namespace Slime::Memory {
}
}

proc create_lisp_object_cfunction(bool is_special) -> Lisp_Object* {
proc create_lisp_object_cfunction(C_Function_Type type) -> Lisp_Object* {
Lisp_Object* node;
try node = create_lisp_object();
set_type(node, Lisp_Object_Type::CFunction);
node->value.cFunction = (cFunction*)malloc(sizeof(cFunction));
node->value.cFunction->args.keyword.keywords.alloc();
node->value.cFunction->args.keyword.values.alloc();
node->value.cFunction->args.positional.symbols.alloc();
node->value.cFunction->is_special_form = is_special;
set_type(node, Lisp_Object_Type::Function);
node->value.function = (Function*)malloc(sizeof(Function));
node->value.function->type.c_function_type = type;
node->value.function->args.keyword.keywords.alloc();
node->value.function->args.keyword.values.alloc();
node->value.function->args.positional.symbols.alloc();
return node;
}

proc create_lisp_object_function(Function_Type ft) -> Lisp_Object* {
proc create_lisp_object_function(Lisp_Function_Type ft) -> Lisp_Object* {
Lisp_Object* func;
try func = Memory::create_lisp_object();
Memory::set_type(func, Lisp_Object_Type::Function);
@@ -444,7 +447,7 @@ namespace Slime::Memory {
func->value.function->args.keyword.keywords.alloc();
func->value.function->args.keyword.values.alloc();
func->value.function->args.positional.symbols.alloc();
func->value.function->type = ft;
func->value.function->type.lisp_function_type = ft;
return func;
}

@@ -465,8 +468,7 @@ namespace Slime::Memory {
if (n == Memory::nil || n == Memory::t ||
Memory::get_type(n) == Lisp_Object_Type::Symbol ||
Memory::get_type(n) == Lisp_Object_Type::Keyword ||
Memory::get_type(n) == Lisp_Object_Type::Function ||
Memory::get_type(n) == Lisp_Object_Type::CFunction)
Memory::get_type(n) == Lisp_Object_Type::Function)
{
return n;
}


+ 21
- 14
src/structs.cpp Ver fichero

@@ -22,7 +22,6 @@ namespace Slime {
HashMap,
// OwningPointer,
Function,
CFunction,
};

enum class Lisp_Object_Flags
@@ -32,9 +31,17 @@ namespace Slime {
Under_Construction = 1 << 6,
};

enum struct Function_Type {
Lambda,
Macro
enum struct Lisp_Function_Type {
Lambda, // normal evaluation order
Macro // args are not evaluated, a new programm is returned
// that will be executed again
};
enum struct C_Function_Type {
cFunction, // normal evaluation order
cSpecial, // args are not evaluated, but result is returned
// as you would expect
cMacro // No return value, but the current_execution is
// modified
};

enum struct Log_Level {
@@ -101,16 +108,17 @@ namespace Slime {
};

struct Function {
Function_Type type;
Arguments args;
Lisp_Object* body; // maybe implicit begin
Environment* parent_environment; // we are doing closures now!!
};

struct cFunction {
Lisp_Object* (*body)();
Arguments args;
bool is_special_form;
Environment* parent_environment;
bool is_c;
union {
Lisp_Function_Type lisp_function_type;
C_Function_Type c_function_type;
} type;
union {
Lisp_Object* lisp_body;
Lisp_Object* (*c_body)();
} body;
};

struct Lisp_Object {
@@ -125,7 +133,6 @@ namespace Slime {
Pair pair;
Vector vector;
Function* function;
cFunction* cFunction;
void* pointer;
Continuation* continuation;
Hash_Map<Lisp_Object*, Lisp_Object*>* hashMap;


+ 40
- 40
src/testing.cpp Ver fichero

@@ -623,49 +623,49 @@ namespace Slime {
}
};

push_environment(Memory::create_child_environment(
get_current_environment()));
printf("-- Util --\n");
invoke_test(test_array_lists_adding_and_removing);
invoke_test(test_array_lists_sorting);
invoke_test(test_array_lists_searching);
printf("\n -- Parsing --\n");
invoke_test(test_parse_atom);
invoke_test(test_parse_expression);
printf("\n-- Basic evaluating --\n");
invoke_test(test_eval_operands);
printf("\n-- Built ins --\n");
invoke_test(test_built_in_add);
invoke_test(test_built_in_substract);
invoke_test(test_built_in_multiply);
invoke_test(test_built_in_divide);
invoke_test(test_built_in_if);
invoke_test(test_built_in_and);
invoke_test(test_built_in_or);
invoke_test(test_built_in_not);
invoke_test(test_built_in_type);
printf("\n-- Memory management --\n");
invoke_test(test_singular_t_and_nil);
invoke_test(test_singular_symbols);
pop_environment();
// push_environment(Memory::create_child_environment(
// get_current_environment()));
// printf("-- Util --\n");
// invoke_test(test_array_lists_adding_and_removing);
// invoke_test(test_array_lists_sorting);
// invoke_test(test_array_lists_searching);
// printf("\n -- Parsing --\n");
// invoke_test(test_parse_atom);
// invoke_test(test_parse_expression);
// printf("\n-- Basic evaluating --\n");
// invoke_test(test_eval_operands);
// printf("\n-- Built ins --\n");
// invoke_test(test_built_in_add);
// invoke_test(test_built_in_substract);
// invoke_test(test_built_in_multiply);
// invoke_test(test_built_in_divide);
// invoke_test(test_built_in_if);
// invoke_test(test_built_in_and);
// invoke_test(test_built_in_or);
// invoke_test(test_built_in_not);
// invoke_test(test_built_in_type);
// printf("\n-- Memory management --\n");
// invoke_test(test_singular_t_and_nil);
// invoke_test(test_singular_symbols);
// pop_environment();
printf("\n-- Test Files --\n");

invoke_test_script("evaluation_of_default_args");
invoke_test_script("alists");
invoke_test_script("case_and_cond");
invoke_test_script("lexical_scope");
invoke_test_script("class_macro");
invoke_test_script("import_and_load");
invoke_test_script("macro_expand");
invoke_test_script("automata");
// invoke_test_script("evaluation_of_default_args");
// invoke_test_script("alists");
// invoke_test_script("case_and_cond");
// invoke_test_script("lexical_scope");
// invoke_test_script("class_macro");
// invoke_test_script("import_and_load");
// invoke_test_script("macro_expand");
// invoke_test_script("automata");
invoke_test_script("sicp");
invoke_test_script("hashmaps");
invoke_test_script("singular_imports");
// invoke_test_script("hashmaps");
// invoke_test_script("singular_imports");

return result;
}


Escribir Vista previa
Cargando…
Cancelar
Guardar