diff --git a/example.scm b/example.scm new file mode 100644 index 0000000..a8fb2b7 --- /dev/null +++ b/example.scm @@ -0,0 +1,47 @@ + +; Test functions + +(define add-three (lambda (x y z) (+ (+ x z) y))) + +; Test factorial + +(define fac (lambda (x) (if (>= x 1) (* x (fac (+ x -1))) 1))) + +(define (faca x a) + (if (>= x 1) + (faca (+ x -1) (* x a)) + a)) + +(define x 5) +(display x) (newline) +(display (fac x)) (newline) +(display (faca x 1)) (newline) + +; Test stuff? + +(define (f . l) (cdr l)) +(define y '(1 2 3)) + +(display y) (newline) +(display (car y)) (newline) +(display (cdr y)) (newline) + +; Check set! + +(set! x 10) +(display x) (newline) + +; Test syntax-rules + +(define-syntax and + (syntax-rules () + ((and) #t) + ((and test) test) + ((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 #f)) (newline) + diff --git a/tigerscheme.tig b/tigerscheme.tig index 72a50a2..fe458a2 100644 --- a/tigerscheme.tig +++ b/tigerscheme.tig @@ -262,6 +262,11 @@ let /* Booleans */ in ascii = 41 end + function is_comment_start (index: int): int = + let var ascii := ord(substring(str, index, 1)) + in ascii = ord(";") + end + function is_tick (index: int): int = let var ascii := ord(substring(str, index, 1)) in ascii = ord("'") @@ -320,8 +325,16 @@ let /* Booleans */ , pos_r = pos_r } function ignore_ws () = - while index < size(str) & is_ws(index) - do index := index + 1 + /* Ignore whitespace */ + if index < size(str) & is_ws(index) + then (index := index + 1; ignore_ws()) + + /* Handle comments, ignore until newline */ + else if is_comment_start(index) + then ( while ord(substring(str, index, 1)) <> ord("\n") + do index := index + 1 + ; ignore_ws()) + function parse_rec (): sexp_ast = ( ignore_ws() @@ -485,6 +498,8 @@ let /* Booleans */ var OPCODE_CAR := 20 var OPCODE_CDR := 16 var OPCODE_SET := 21 + var OPCODE_FRSTR := 22 + var OPCODE_COMPILE:= 23 var vm_insn_num_opcodes := 0 var vm_insn_info := @@ -526,14 +541,18 @@ let /* Booleans */ ; code(OPCODE_DEFFUN, "DEFFUN", 1, 0, 0) ; code(OPCODE_POP, "POP", 0, 0, 0) ; code(OPCODE_GEQ, "GEQ", 0, 0, 0) - ; code(OPCODE_OUTPUT, "OUTPUT", 0, 0, 0) - ; code(OPCODE_TOSTR, "TOSTR", 0, 0, 0) ; code(OPCODE_CONS, "CONS", 0, 0, 0) ; code(OPCODE_CAR, "CAR", 0, 0, 0) ; code(OPCODE_CDR, "CDR", 0, 0, 0) ; code(OPCODE_SET, "SET", 0, 1, 0) + ; code(OPCODE_OUTPUT, "OUTPUT", 0, 0, 0) + ; code(OPCODE_TOSTR, "TOSTR", 0, 0, 0) + ; code(OPCODE_FRSTR, "FRSTR", 0, 0, 0) + + ; code(OPCODE_COMPILE,"COMPILE", 0, 0, 0) + ; for i := 1 to expected_number_opcodes - 1 do if a[i] <> nil & a[i-1] = nil then print(concatm("Error: Opcode info array incorrectly initialized!\n Opcode " @@ -569,7 +588,11 @@ let /* Booleans */ else if b = nil | b.first = nil then () else if (a.first = nil & a.last <> nil) | (a.first <> nil & a.last = nil) - then print(concat("Error: Instruction list invariant not maintained! First is ", concat(if a.first = nil then "" else "not ", concat( "nil, second is ", concat(if a.last = nil then "" else "not ", "nil\n"))))) + then print(concatm( "Error: Instruction list invariant not maintained! First is " + , if a.first = nil then "" else "not " + , "nil, second is " + , if a.last = nil then "" else "not " + , "nil\n")) else if a.first = nil then ( a.first := b.first ; a.last := b.last ) @@ -1354,9 +1377,15 @@ let /* Booleans */ let var tape_size := tape.length var tape := tape.tape + var continue := true + function vm_update () = - if tape[ip] = nil - then ip := -1 + if not(continue) + then () + else if tape[ip] = nil + then run_error("Missing instruction in tape") + else if not (0 <= ip & ip < tape_size) + then run_error("Instruction pointer out of bounds") /* Integer binary operators */ else if let var op := tape[ip].opcode @@ -1544,10 +1573,10 @@ let /* Booleans */ ; print("\n Scheme: ") ; print(safe_substring(source, tape[ip].pos_l, tape[ip].pos_r)) ; print("\n") - ; ip := -1 + ; continue := false end - in while 0 <= ip & ip < tape_size + in while continue do ( vm_update() ; if DEBUG_PRINT_STACK then ( print("[") @@ -1555,42 +1584,20 @@ let /* Booleans */ ; print("]: ") ; print(stack_to_string(stack)) ; print("\n") )) - ; if not (0 <= ip & ip < tape_size) - then print("Died due to out of bounds instruction pointer.\n") end /* Do stuff */ - var test_text := "(begin (define add-three (lambda (x y z) (+ (+ x z) y))) \ - \ (define fac (lambda (x) (if (>= x 1) (* x (fac (+ x -1))) 1))) \ - \ (define (faca x a) \ - \ (if (>= x 1) \ - \ (faca (+ x -1) (* x a)) \ - \ a)) \ - \ (define (f . l) (cdr l)) \ - \ (define x 5) \ - \ (define y '(1 2 3)) \ - \ (display x) (newline) \ - \ (display (fac x)) (newline) \ - \ (display (faca x 1)) (newline) \ - \ (display y) (newline) \ - \ (display (car y)) (newline) \ - \ (display (cdr y)) (newline) \ - \ (set! x 10) \ - \ (display x) (newline) \ + var test_text := + /* TODO: Improve top-level parsing */ + let var text := "(begin " + var char := "BAD SHIT HAPPENED" + in while char <> "" + do ( char := getchar() + ; text := concat(text, char) ) + ; concat(text, " )") + end - \ (define-syntax and \ - \ (syntax-rules ()\ - \ ((and) #t)\ - \ ((and test) test)\ - \ ((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 #f)) (newline) \ - \) " var ignore := ( print("** Parsing **\n") ; print("Original : ") ; print(test_text)