From e14eaa1dd13a9acc2955d1916b6daf4729acefea Mon Sep 17 00:00:00 2001 From: Jon Michael Aanes Date: Fri, 28 Dec 2018 13:01:42 +0100 Subject: [PATCH] Added tape resizing and more tests. --- example.scm | 47 +++++++++++++++++++++++++++--------- tigerscheme.tig | 64 +++++++++++++++++++++++++++++++++++-------------- 2 files changed, 82 insertions(+), 29 deletions(-) diff --git a/example.scm b/example.scm index 8fca8b7..8ae4499 100644 --- a/example.scm +++ b/example.scm @@ -109,8 +109,6 @@ (display (f 1 5)) (newline) -(exit) - ; Check set! (set! x 10) @@ -154,6 +152,24 @@ (display (reverse '(1 2 3 4 5))) (newline) +(newline) +(display "* R5RS: Test if-expressions*") +(newline) + +(display "If-then exp!\n\tExpect: 6\n\tGotten: ") +(display (* 3 (if #t 2 0))) +(newline) + +(display "If-else exp!\n\tExpect: 0\n\tGotten: ") +(display (* 3 (if #f 2 0))) +(newline) + +(display "If-one-branch exp!\n\tExpect: Hello World\n\tGotten: ") +(if #t (display "Hello World\n")) + +(display "If-one-branch exp!\n\tExpect: \n\tGotten: ") +(if #f (display "Hello World\n")) + (newline) (display "* R5RS: Testing Eval system *") (newline) @@ -184,12 +200,14 @@ (display "\n* R5RS: Lexical convention *\n") -(display "Test case-insensitivity (required by R5RS)\n\tExpect: 20 20 20 20") (define a-variable 20) -(display a-variable) (display " ") -(display A-variable) (display " ") -(display a-VARiable) (display " ") -(display A-VARIABLE) +(if #f (begin + (display "Test case-insensitivity (required by R5RS)\n\tExpect: 20 20 20 20\n\tGotten: ") + (display a-variable) (display " ") + (display A-variable) (display " ") + (display a-VARiable) (display " ") + (display A-VARIABLE)) + (display "Skipped test!\n")) ; Test environment set @@ -207,8 +225,11 @@ ; Test syntax-rules +(newline) +(display "* Testing syntax-rules (move to macro once implemented) *") +(newline) -(exit) +(display "Attempting to define and using syntax rules.\n\tExpect: #t #f #f #f\n\tGotten: ") (define-syntax and (syntax-rules () @@ -217,8 +238,12 @@ ((and test1 test2 ...) (if test1 (and test2 ...) #f)))) -(display (and #t #t)) (newline) -(display (and #f #t)) (newline) -(display (and #f #f)) (newline) +(display (and #t #t)) (display " ") +(display (and #f #t)) (display " ") +(display (and #f #f)) (display " ") (display (and #t #f)) (newline) +; TODO: Use syntax-rules to implement let and or. + +(display "") + diff --git a/tigerscheme.tig b/tigerscheme.tig index 2c4a208..bfb1634 100644 --- a/tigerscheme.tig +++ b/tigerscheme.tig @@ -13,6 +13,8 @@ let /* Booleans */ var DEBUG_PRINT_TAPE : bool := false var DEBUG_PRINT_PARSED : bool := false + var ALLOW_TAPE_RESIZE : bool := true + var TRIGGERED_EXIT : bool := false /* Basic utility */ @@ -613,7 +615,7 @@ let /* Booleans */ , pos_r: pos } type vm_tape_tape = array of vm_insn - type vm_tape = { length: int + type vm_tape = { capacity: int , filled: int , tape: vm_tape_tape } @@ -739,19 +741,53 @@ let /* Booleans */ type vm_insn_list_link = { insn: vm_insn, next: vm_insn_list_link } type vm_insn_list = { first: vm_insn_list_link, last: vm_insn_list_link } + function insn_list_length (insns: vm_insn_list): int = + let var len := 0 + var head := insns.first + in while head <> nil + do ( len := len + 1 + ; head := head.next ) + ; len + end + function tape_new (init_size: int): vm_tape = - vm_tape { length = init_size + vm_tape { capacity = init_size , filled = 0 , tape = vm_tape_tape [init_size] of nil } + function tape_resize(tape: vm_tape, new_size: int) = + let var new_tape_tape := vm_tape_tape [new_size] of nil + in for i := 0 to tape.filled - 1 + do new_tape_tape[i] := tape.tape[i] + ; tape.tape := new_tape_tape + end + function tape_append(tape: vm_tape, new_insns: vm_insn_list): int = - let var head := new_insns.first + let var head := new_insns.first var index_start := tape.filled - var index := index_start - var real_tape := tape.tape + var index := index_start + var new_insns := insn_list_length(new_insns) /* TODO: Ensure enough space on tape for new additions. */ - in while head <> nil - do ( real_tape[index] := head.insn + + /* Check if resize is not required, and then do nothing */ + in if tape.filled + new_insns <= tape.capacity + then () + + /* Check if resize is required, and allowed */ + else if ALLOW_TAPE_RESIZE + then tape_resize(tape, 2 * (tape.capacity + new_insns)) + + /* Check if resize is required, but not allowed */ + else ( print("Tape with ") + ; print(int_to_string(tape.filled)) + ; print("/") + ; print(int_to_string(tape.capacity)) + ; print(" instructions have exceeded its capacity. Attempt to add ") + ; print(int_to_string(new_insns)) + ; print(" new instructions is impossible.\n")) + + ; while head <> nil + do ( tape.tape[index] := head.insn ; index := index + 1 ; head := head.next ) ; tape.filled := index @@ -815,15 +851,6 @@ let /* Booleans */ ; insns end - function insn_list_length (insns: vm_insn_list): int = - let var len := 0 - var head := insns.first - in while head <> nil - do ( len := len + 1 - ; head := head.next ) - ; len - end - var ENV_EMPTY : vm_env := nil_val() var ENV_STD : vm_env := ENV_EMPTY @@ -1487,7 +1514,8 @@ let /* Booleans */ var insns_then := compile_rec(ast.val_cdr.val_cdr.val_car, can_tail_call) var insns_else := if ast.val_cdr.val_cdr.val_cdr.typ = type_pair then compile_rec(ast.val_cdr.val_cdr.val_cdr.val_car, can_tail_call) - else compile_rec(VALUE_UNSPECIFIED, can_tail_call) + else tail_position_one( atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r) + , can_tail_call) var jump_then := sexp_ast_length(insns_then) + 1 var jump_else := sexp_ast_length(insns_else) + 1 + 1 @@ -1678,7 +1706,7 @@ let /* Booleans */ end function optimize_vm_tape (real_tape: vm_tape): vm_tape = - let var len := real_tape.length + let var len := real_tape.capacity var tape := real_tape.tape in for index := 0 to len - 1 do if tape[index+0].opcode = OPCODE_PUSH