Selaa lähdekoodia

environments are now hashmaps

master
FelixBrendel 6 vuotta sitten
vanhempi
commit
2882f81e13
9 muutettua tiedostoa jossa 124 lisäystä ja 117 poistoa
  1. +12
    -10
      bin/alist.slime
  2. +7
    -7
      bin/pre.slime
  3. +7
    -7
      bin/pre.slime.expanded
  4. +33
    -33
      bin/tests/alists.slime
  5. +0
    -2
      bin/tests/evaluation_of_default_args.slime
  6. +14
    -7
      src/built_ins.cpp
  7. +17
    -17
      src/env.cpp
  8. +1
    -1
      src/ftb
  9. +33
    -33
      src/testing.cpp

+ 12
- 10
bin/alist.slime Näytä tiedosto

@@ -3,11 +3,11 @@
(alist::make alist::print alist::get alist::find alist::key-exists? alist::remove! alist::set! alist::set-overwrite!
plist::make plist::print plist::get plist::find plist::prop-exists? plist::remove! plist::set! plist::set-overwrite!)

(define key-not-found-index -1)

(define-module alist
:imports ("cxr.slime")
:exports (make print get find key-exists? remove! set! set-overwrite!)
(define key-not-found-index -1)

(define (make)
(set-type!
@@ -33,7 +33,7 @@
(let ((associations (first alist)))
(define (alist-get-intern associations key)
(cond ((null? associations)
(error "key was not found in alist"))
(error :key-not-found "key was not found in alist"))
((= (caar associations) key)
(cdar associations))
(else (alist-get-intern (rest associations) key))))
@@ -52,12 +52,12 @@


(define (key-exists? alist key)
(not (= (alist-find alist key)
(not (= (find alist key)
key-not-found-index)))


(define (remove! alist key)
(let ((index (alist-find alist key)))
(let ((index (find alist key)))
(define (alist-remove!-internal asociations index)
;; reminder: we only get called if we are not replacing the
;; first element in the alist
@@ -70,7 +70,7 @@
;; else cdr-recurse
(alist-remove!-internal (rest asociations) (- index 1))))

(cond ((= index key-not-found-index) (error "key to remove was not found"))
(cond ((= index key-not-found-index) (error :key-not-found "key to remove was not found"))
((= index 0) (mutate alist (pair (cdar alist) ())))
(else (alist-remove!-internal alist index))))
alist)
@@ -87,7 +87,7 @@
(define (alist-set-overwrite-intern associations key value)
(cond ((= (caar associations) key)
(mutate (car associations) (pair key value)))
((null? associations) (alist-set! alist key value))
((null? associations) (set! alist key value))
(else (alist-set-overwrite-intern
(rest associations) key value))))
(alist-set-overwrite-intern associations key value))
@@ -108,6 +108,8 @@
;;
;; '((:key1 value1 :key2 value2))

(define key-not-found-index -1)

(define (make)
(set-type!
'(())
@@ -131,7 +133,7 @@
(let ((props (first plist)))
(define (plist-get-intern props prop)
(cond ((null? props)
(error "property was not found in plist"))
(error :key-not-found "property was not found in plist"))
((= (car props) prop)
(cadr props))
(else (plist-get-intern (cddr props) prop))))
@@ -162,11 +164,11 @@
(plist-find-intern props prop 0)))

(define (prop-exists? plist prop)
(not (= (plist-find plist prop)
(not (= (find plist prop)
key-not-found-index)))

(define (remove! plist prop)
(let ((index (plist-find plist prop)))
(let ((index (find plist prop)))
(define (plist-remove!-internal props index)
;; reminder: we only get called if we are not replacing the
;; first element in the alist
@@ -179,7 +181,7 @@
;; else cdr-recurse
(plist-remove!-internal (cddr props) (- index 1))))

(cond ((= index key-not-found-index) (error "prop to remove was not found"))
(cond ((= index key-not-found-index) (error :key-not-found "prop to remove was not found"))
((= index 0) (mutate plist (pair (cddar plist) ())))
(else (plist-remove!-internal plist index))))
plist)


+ 7
- 7
bin/pre.slime Näytä tiedosto

@@ -57,7 +57,7 @@ condition is false."
(if (= (first (first clauses)) 'else)
(begin
(if (not (= (rest clauses) ()))
(error "There are additional clauses after the else clause!")
(error :syntax-error "There are additional clauses after the else clause!")
(pair 'begin (rest (first clauses)))))
`(if ,(first (first clauses))
(begin @(rest (first clauses)))
@@ -72,7 +72,7 @@ condition is false."
(if (= (first (first clauses)) 'else)
(begin
(if (not (= (rest clauses) ()))
(error "There are additional clauses after the else clause!")
(error :syntax-error "There are additional clauses after the else clause!")
(pair 'begin (rest (first clauses)))))
`(if (member? ,var ',(first (first clauses)))
(begin @(rest (first clauses)))
@@ -119,7 +119,7 @@ condition is false."
`(when ,(first (rest body)) ,(rec (rest (rest body)))))
((= (first (rest body)) 'yield)
(first (rest body)))
(else (error "Not a do-able expression"))))
(else (error :syntax-error "Not a do-able expression"))))

(rec body))

@@ -151,7 +151,7 @@ ithe sequence as arguemens."
(symbol->string orig-export-name)))))
`(define ,export-name
,(mytry (eval orig-export-name)
(error "The module does not contain" orig-export-name)))))
(error :module-error "The module does not contain a key it tries to export")))))
exports))))


@@ -181,7 +181,7 @@ ithe sequence as arguemens."
(desired-type (first (rest objs))))
(if (= actual-type desired-type)
(inner (rest (rest objs)))
(error "type missmatch" actual-type desired-type)))))
(error :type-missmatch "type missmatch" actual-type desired-type)))))
(inner objs))

(define (number? x)
@@ -288,14 +288,14 @@ with (pair elem nil)."

(define (sublist-starting-at-index seq index)
(cond ((< index 0)
(error "sublist-starting-at-index: index must be positive"))
(error :index-out-of-range "sublist-starting-at-index: index must be positive"))
((null? seq) ())
((= 0 index) seq)
(else (sublist-starting-at (rest seq) (- index 1)))))

(define (list-without-index seq index)
(cond ((or (< index 0) (null? seq))
(error "list-remove-index!: index out of range"))
(error :index-out-of-range "list-remove-index!: index out of range"))
((= 0 index) (rest seq))
(else (pair (first seq) (list-without-index (rest seq) (- index 1))))))



+ 7
- 7
bin/pre.slime.expanded Näytä tiedosto

@@ -8,19 +8,19 @@

(define-syntax (let bindings . body) (define (unzip lists) (when lists (define (iter lists l1 l2) (define elem (first lists)) (if elem (iter (rest lists) (pair (first elem) l1) (pair (first (rest elem)) l2)) (list l1 l2)))) (iter lists () ())) (define unzipped (unzip bindings)) `((,lambda ,(first unzipped) (unquote-splicing body)) (unquote-splicing (first (rest unzipped)))))

(define-syntax (cond . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) 'else) (begin (if (not (= (rest clauses) ())) (error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if ,(first (first clauses)) (begin (unquote-splicing (rest (first clauses)))) ,(rec (rest clauses)))))) (rec clauses))
(define-syntax (cond . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) 'else) (begin (if (not (= (rest clauses) ())) (error :syntax-error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if ,(first (first clauses)) (begin (unquote-splicing (rest (first clauses)))) ,(rec (rest clauses)))))) (rec clauses))

(define-syntax (case var . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) 'else) (begin (if (not (= (rest clauses) ())) (error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if (member? ,var ',(first (first clauses))) (begin (unquote-splicing (rest (first clauses)))) ,(rec (rest clauses)))))) (rec clauses))
(define-syntax (case var . clauses) (define (rec clauses) (if (= nil clauses) nil (if (= (first (first clauses)) 'else) (begin (if (not (= (rest clauses) ())) (error :syntax-error "There are additional clauses after the else clause!") (pair 'begin (rest (first clauses))))) `(if (member? ,var ',(first (first clauses))) (begin (unquote-splicing (rest (first clauses)))) ,(rec (rest clauses)))))) (rec clauses))

(define-syntax (define-special name-and-args . body) `(define ,(first name-and-args) (special-lambda ,(rest name-and-args) (unquote-splicing body))))

(define-syntax (construct-list . body) :doc "\n{{{example_start}}}\n(construct-list\n i <- '(1 2 3 4 5)\n yield (* i i))\n{{{example_end}}}\n\n(construct-list\n i <- '(1 2 3 4)\n j <- '(A B)\n yield (pair i j))\n\n(construct-list\n i <- '(1 2 3 4 5 6 7 8)\n if (= 0 (% i 2))\n yield i)\n" (define (append-map f ll) (unless (= ll ()) (define val (f (first ll))) (if (= (first val) ()) (append-map f (rest ll)) (extend val (append-map f (rest ll)))))) (define (rec body) (cond ((= () body) ()) ((= () (rest body)) (first body)) ((= (first (rest body)) '<-) `(,append-map (lambda (,(first body)) (list ,(rec (rest (rest (rest body)))))) ,(first (rest (rest body))))) ((= (first body) 'if) `(when ,(first (rest body)) ,(rec (rest (rest body))))) ((= (first (rest body)) 'yield) (first (rest body))) (else (error "Not a do-able expression")))) (rec body))
(define-syntax (construct-list . body) :doc "\n{{{example_start}}}\n(construct-list\n i <- '(1 2 3 4 5)\n yield (* i i))\n{{{example_end}}}\n\n(construct-list\n i <- '(1 2 3 4)\n j <- '(A B)\n yield (pair i j))\n\n(construct-list\n i <- '(1 2 3 4 5 6 7 8)\n if (= 0 (% i 2))\n yield i)\n" (define (append-map f ll) (unless (= ll ()) (define val (f (first ll))) (if (= (first val) ()) (append-map f (rest ll)) (extend val (append-map f (rest ll)))))) (define (rec body) (cond ((= () body) ()) ((= () (rest body)) (first body)) ((= (first (rest body)) '<-) `(,append-map (lambda (,(first body)) (list ,(rec (rest (rest (rest body)))))) ,(first (rest (rest body))))) ((= (first body) 'if) `(when ,(first (rest body)) ,(rec (rest (rest body))))) ((= (first (rest body)) 'yield) (first (rest body))) (else (error :syntax-error "Not a do-able expression")))) (rec body))

(define-syntax (apply fun seq) :doc "Applies the function to the sequence, as in calls the function with\nithe sequence as arguemens." `(eval (pair ,fun ,seq)))

(define-syntax (define-typed args . body) (define (get-arg-names args) (when args (pair (first args) (get-arg-names (rest (rest args)))))) (let ((name (first args)) (lambda-list (rest args)) (arg-names (get-arg-names (rest args)))) `(define (,name (unquote-splicing arg-names)) (assert-types= (unquote-splicing lambda-list)) (unquote-splicing body))))

(define-syntax (define-module module-name (:imports ()) :exports . body) (let ((module-prefix (concat-strings (symbol->string module-name) "::"))) (eval `(begin (unquote-splicing (map (lambda (x) `(,import ,x)) imports)) (unquote-splicing body))) (pair 'begin (map (lambda (orig-export-name) (let ((export-name (string->symbol (concat-strings module-prefix (symbol->string orig-export-name))))) `(define ,export-name ,(mytry (eval orig-export-name) (error "The module does not contain" orig-export-name))))) exports))))
(define-syntax (define-module module-name (:imports ()) :exports . body) (let ((module-prefix (concat-strings (symbol->string module-name) "::"))) (eval `(begin (unquote-splicing (map (lambda (x) `(,import ,x)) imports)) (unquote-splicing body))) (pair 'begin (map (lambda (orig-export-name) (let ((export-name (string->symbol (concat-strings module-prefix (symbol->string orig-export-name))))) `(define ,export-name ,(mytry (eval orig-export-name) (error :module-error "The module does not contain a key it tries to export"))))) exports))))

(define (null? x) :doc "Checks if the argument is =nil=." (= x ()))

@@ -28,7 +28,7 @@

(define (types=? . objs) (define (inner objs) (if objs (let ((actual-type (type (first objs))) (desired-type (first (rest objs)))) (if (= actual-type desired-type) (inner (rest (rest objs))) ())) t)) (inner objs))

(define (assert-types= . objs) (define (inner objs) (when objs (let ((actual-type (type (first objs))) (desired-type (first (rest objs)))) (if (= actual-type desired-type) (inner (rest (rest objs))) (error "type missmatch" actual-type desired-type))))) (inner objs))
(define (assert-types= . objs) (define (inner objs) (when objs (let ((actual-type (type (first objs))) (desired-type (first (rest objs)))) (if (= actual-type desired-type) (inner (rest (rest objs))) (error :type-missmatch "type missmatch" actual-type desired-type))))) (inner objs))

(define (number? x) :doc "Checks if the argument is a number." (type=? x :number))

@@ -64,9 +64,9 @@

(define (member? elem seq) (when (pair? seq) (if (= elem (first seq)) t (member? elem (rest seq)))))

(define (sublist-starting-at-index seq index) (cond ((< index 0) (error "sublist-starting-at-index: index must be positive")) ((null? seq) ()) ((= 0 index) seq) (else (sublist-starting-at (rest seq) (- index 1)))))
(define (sublist-starting-at-index seq index) (cond ((< index 0) (error :index-out-of-range "sublist-starting-at-index: index must be positive")) ((null? seq) ()) ((= 0 index) seq) (else (sublist-starting-at (rest seq) (- index 1)))))

(define (list-without-index seq index) (cond ((or (< index 0) (null? seq)) (error "list-remove-index!: index out of range")) ((= 0 index) (rest seq)) (else (pair (first seq) (list-without-index (rest seq) (- index 1))))))
(define (list-without-index seq index) (cond ((or (< index 0) (null? seq)) (error :index-out-of-range "list-remove-index!: index out of range")) ((= 0 index) (rest seq)) (else (pair (first seq) (list-without-index (rest seq) (- index 1))))))

(define (increment val) :doc "Adds one to the argument." (+ val 1))



+ 33
- 33
bin/tests/alists.slime Näytä tiedosto

@@ -1,51 +1,51 @@
(import "alist.slime")

(define a (make-alist))
(define a (ds::alist::make))
;; a == (())

(assert (= (first a) ()))

(alist-set! a 'key1 'value1)
(ds::alist::set! a 'key1 'value1)
;; a == (key1: value1)

(assert (= (alist-get a 'key1) 'value1))
(assert (alist-key-exists? a 'key1))
(assert (not (alist-key-exists? a 'key2)))
(assert (= (ds::alist::get a 'key1) 'value1))
(assert (ds::alist::key-exists? a 'key1))
(assert (not (ds::alist::key-exists? a 'key2)))

(alist-set! a 'key2 'value2)
(ds::alist::set! a 'key2 'value2)
;; a == (key2: value2,
;; key1: value1)

(assert (= (alist-get a 'key2) 'value2))
(assert (alist-key-exists? a 'key2))
(assert (= (alist-find a 'key2) 0))
(assert (= (alist-find a 'key1) 1))
(assert (= (ds::alist::get a 'key2) 'value2))
(assert (ds::alist::key-exists? a 'key2))
(assert (= (ds::alist::find a 'key2) 0))
(assert (= (ds::alist::find a 'key1) 1))
(assert (= (length (first a)) 2))


(alist-set! a 'key1 'value3)
(ds::alist::set! a 'key1 'value3)
;; a == (key1: value3,
;; key2: value2,
;; key1: value1)

(assert (= (length (first a)) 3))
(assert (= (alist-get a 'key1) 'value3))
(assert (= (ds::alist::get a 'key1) 'value3))

(alist-set-overwrite! a 'key1 'value4)
(ds::alist::set-overwrite! a 'key1 'value4)
;; a == (key1: value4,
;; key2: value2,
;; key1: value1)

(assert (= (length (first a)) 3))
(assert (= (alist-get a 'key1) 'value4))
(assert (= (ds::alist::get a 'key1) 'value4))

(alist-remove! a 'key1)
(ds::alist::remove! a 'key1)
;; a == (key2: value2,
;; key1: value1)

(assert (= (length (first a)) 2))
(assert (= (alist-get a 'key1) 'value1))
(assert (= (alist-get a 'key2) 'value2))
(assert (= (ds::alist::get a 'key1) 'value1))
(assert (= (ds::alist::get a 'key2) 'value2))


;; -------------
@@ -54,48 +54,48 @@
;;
;; -------------

(define p (make-plist))
(define p (ds::plist::make))
;; p == (())

(assert (= (first p) ()))

(plist-set! p :key1 'value1)
(ds::plist::set! p :key1 'value1)
;; p == ((:key1 value1))

(assert (= (plist-get p :key1) 'value1))
(assert (plist-prop-exists? p :key1))
(assert (not (plist-prop-exists? p :key2)))
(assert (= (ds::plist::get p :key1) 'value1))
(assert (ds::plist::prop-exists? p :key1))
(assert (not (ds::plist::prop-exists? p :key2)))

(plist-set! p :key2 'value2)
;; p == ((:key2 value2,
;; :key1 value1))

(assert (= (plist-get p :key2) 'value2))
(assert (plist-prop-exists? p :key2))
(assert (= (plist-find p :key2) 0))
(assert (= (plist-find p :key1) 1))
(assert (= (ds::plist::get p :key2) 'value2))
(assert (ds::plist::prop-exists? p :key2))
(assert (= (ds::plist::find p :key2) 0))
(assert (= (ds::plist::find p :key1) 1))
(assert (= (length (first p)) 4))

(plist-set! p :key1 'value3)
(ds::plist::set! p :key1 'value3)
;; p == ((:key1 value3,
;; :key2 value2,
;; :key1 value1))

(assert (= (length (first p)) 6))
(assert (= (plist-get p :key1) 'value3))
(assert (= (ds::plist::get p :key1) 'value3))

(plist-set-overwrite! p :key1 'value4)
(ds::plist::set-overwrite! p :key1 'value4)
;; p == ((:key1 value4,
;; :key2 value2,
;; :key1 value1))

(assert (= (length (first p)) 6))
(assert (= (plist-get p :key1) 'value4))
(assert (= (ds::plist::get p :key1) 'value4))

(plist-remove! p :key1)
(ds::plist::remove! p :key1)
;; p == ((:key2 value2,
;; :key1 value1))

(assert (= (length (first p)) 4))
(assert (= (plist-get p :key1) 'value1))
(assert (= (plist-get p :key2) 'value2))
(assert (= (ds::plist::get p :key1) 'value1))
(assert (= (ds::plist::get p :key2) 'value2))

+ 0
- 2
bin/tests/evaluation_of_default_args.slime Näytä tiedosto

@@ -13,5 +13,3 @@
(define (b (:k (begin (break) (a))))
k)
(b))))

(print "k was" (test))

+ 14
- 7
src/built_ins.cpp Näytä tiedosto

@@ -1055,13 +1055,20 @@ proc load_built_ins_into_environment() -> void {
// shouldn't the string itself also get copied??
return Memory::copy_lisp_object(obj);
};
// // defun("error", "TODO", __LINE__, cLambda {
// // // TODO(Felix): make the error function useful
// // try evaluated_arguments = eval_arguments(arguments, &arguments_length);
// // try assert_arguments_length(0, arguments_length);
// // create_generic_error("Userlanderror");
// // return nullptr;
// // });
define((error type message), "TODO") {
fetch(type, message);
// TODO(Felix): make the error function useful
try assert_type(type, Lisp_Object_Type::Keyword);
try assert_type(message, Lisp_Object_Type::String);

using Globals::error;
error = new(Error);
error->type = type;
error->message = message->value.string;

create_generic_error("Userlanderror");
return nullptr;
};
define((symbol->keyword sym), "TODO") {
fetch(sym);
try assert_type(sym, Lisp_Object_Type::Symbol);


+ 17
- 17
src/env.cpp Näytä tiedosto

@@ -90,25 +90,25 @@ proc print_indent(int indent) -> void {
}

proc print_environment_indent(Environment* env, int indent) -> void {
if(env == get_root_environment()) {
// if(env == get_root_environment()) {
// print_indent(indent);
// printf("[built-ins]-Environment (%lld)\n", (long long)env);
// return;
// }

for_str_hash_map (env->hm) {
print_indent(indent);
printf("[built-ins]-Environment (%lld)\n", (long long)env);
return;
printf("-> %s :: ", key);
print((Lisp_Object*)value);
printf(" (%lld)", (unsigned long long)value);
puts("");
}
for (int i = 0; i < env->parents.next_index; ++i) {
print_indent(indent);
printf("parent (%lld)", (long long)env->parents.data[i]);
puts(":");
print_environment_indent(env->parents.data[i], indent+4);
}
printf("TODO\n");
// for (int i = 0; i < env->next_index; ++i) {
// print_indent(indent);
// printf("-> %s :: ", env->keys[i]);
// print(env->values[i]);
// printf(" (%lld)", (long long)env->values[i]);
// puts("");
// }
// for (int i = 0; i < env->parents.next_index; ++i) {
// print_indent(indent);
// printf("parent (%lld)", (long long)env->parents.data[i]);
// puts(":");
// print_environment_indent(env->parents.data[i], indent+4);
// }
}

proc print_environment(Environment* env) -> void {


+ 1
- 1
src/ftb

@@ -1 +1 @@
Subproject commit b9de82c0d84384a7ab78e2cb7dd368612efa50f9
Subproject commit 854593273fdf8039d8ac1ac7150527fca47818ef

+ 33
- 33
src/testing.cpp Näytä tiedosto

@@ -605,43 +605,43 @@ proc run_all_tests() -> bool {
pop_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);
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);

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("sicp");
// invoke_test_script("macro_expand");
// invoke_test_script("automata");
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("sicp");
invoke_test_script("macro_expand");
invoke_test_script("automata");


return result;


Ladataan…
Peruuta
Tallenna