diff --git a/example.scm b/example.scm index 080eace..5ac1a58 100644 --- a/example.scm +++ b/example.scm @@ -3,7 +3,6 @@ ; Lists -; (define (foldl f i l) (if (null? l) i @@ -14,6 +13,7 @@ i (f (car l) (foldr f i (cdr l))))) + (define (map f l) (if (null? l) '() @@ -25,6 +25,8 @@ (define (reverse l) (foldl cons '() l)) +(define (append l1 l2) + (foldr cons l2 l1)) (define list-tail; Taken from https://people.csail.mit.edu/jaffer/r5rs/Pairs-and-lists.html (lambda (x k) @@ -73,6 +75,34 @@ (display y) (newline) (display (car y)) (newline) (display (cdr y)) (newline) +(display (append '(1 2 3) '(4 5 6))) (newline) + +(display "\n* R5RS: Quotation and quasi-quotation *\n") + +(display "Testing quotation!\n\tExpect: (1 2 3)\n\tGotten: ") +(define (x) (quote (1 2 3))) +(display (x)) +(newline) + +(display "Testing quotation!\n\tExpect: (1 2 3)\n\tGotten: ") +(define (x) '(1 2 3)) +(display (x)) +(newline) + +(display "Testing quasi-notation basics!\n\tExpect: (1 2 3)\n\tGotten: ") +(define (x) `(1 2 3)) +(display (x)) +(newline) + +(display "Testing quasi-notation!\n\tExpect: (1 a 2 a 3 a 4)\n\tGotten: ") +(define (x p) `(1 ,p 2 ,p 3 ,p 4)) +(display (x 'a)) +(newline) + +(display "Testing quasi-notation advanced!\n\tExpect: (1 2 3 4 5)\n\tGotten: ") +(define (x p) `(1 ,@p 3)) +(display (x '(2 3 4))) +(newline) ; Check set! @@ -117,6 +147,34 @@ (display (reverse '(1 2 3 4 5))) (newline) +(newline) +(display "* R5RS: Testing Eval system *") +(newline) + +(display "Eval expression. Expect 6: ") +(display (eval '(* 2 (cdr '(2 . 3))) (scheme-report-environment 5))) +(newline) + +(newline) +(display "* R5RS: Testing Macro system *") +(newline) + +; Test define-syntax + +(display "Test define-syntax:\n Expect: 4 ()\n Gotten: ") + +(define-syntax const + (lambda (so) + `(lambda () ,(car (cdr so))))) + +(define x (const 4)) +(display (x)) +(display " ") +(define x (const '())) +(display (x)) +(display "\n") + + ; Test environment set (newline) @@ -131,37 +189,10 @@ (display (cdr (string->datum "(display 2)"))) (newline) -(newline) -(display "* Testing Eval system *") -(newline) - -(display "Eval expression. Expect 6: ") -(display (eval '(* 2 (cdr '(2 . 3))) (scheme-report-environment 5))) -(newline) - -(newline) -(display "* Testing Macro system *") -(newline) - -; Test define-syntax - -(display "Test define-syntax:\n Expect: 4 ()\n Gotten: ") - -(define-syntax const - (lambda (so) - (cons 'lambda (cons '() (cdr so))))) - -(define x (const 4)) -(display (x)) -(display " ") -(define x (const '())) -(display (x)) -(display "\n") - ; Test syntax-rules - +(exit) (define-syntax and (syntax-rules () diff --git a/tigerscheme.tig b/tigerscheme.tig index 288089d..96add10 100644 --- a/tigerscheme.tig +++ b/tigerscheme.tig @@ -7,10 +7,11 @@ let /* Booleans */ /* Settings */ - var IS_NIL_TRUTHY : bool := false - var HAS_NIL_SYMBOL : bool := false - var DEBUG_PRINT_STACK : bool := false - var DEBUG_PRINT_TAPE : bool := false + var IS_NIL_TRUTHY : bool := false + var HAS_NIL_SYMBOL : bool := false + var DEBUG_PRINT_STACK : bool := false + var DEBUG_PRINT_TAPE : bool := false + var DEBUG_PRINT_PARSED : bool := false var TRIGGERED_EXIT : bool := false @@ -327,24 +328,31 @@ let /* Booleans */ function is_left_paren (index: int): bool = is_char("(", index) function is_right_paren (index: int): bool = is_char(")", index) function is_comment_start (index: int): bool = is_char(";", index) - function is_tick (index: int): bool = is_char("'", index) function is_goose_marks (index: int): bool = is_char("\"", index) + function is_quick_modifier (index: int): bool = + is_char("'", index) + | is_char("`", index) + | (is_char(",", index) & is_char("@", index+1)) + | is_char(",", index) + function is_ws (index: int): int = let var ascii := ord(substring(str, index, 1)) in ascii = 32 | ascii = 9 | ascii = 10 end - function is_symbol (index: int): int = + function is_symbol (index: int): bool = let var ascii := ord(substring(str, index, 1)) - in not ( ascii = 9 - | ascii = 10 - | ascii = 32 - | ascii = 40 - | ascii = 41 - | ascii = ord("\"") - | ascii = ord("'") - | ascii = ord(";") ) + in ord("0") <= ascii & ascii <= ord("9") + | ord("a") <= ascii & ascii <= ord("z") + | ord("A") <= ascii & ascii <= ord("Z") + | ascii = ord("!") | ascii = ord("$") | ascii = ord("%") + | ascii = ord("&") | ascii = ord("*") | ascii = ord("/") + | ascii = ord(":") | ascii = ord("<") | ascii = ord("=") + | ascii = ord(">") | ascii = ord("?") | ascii = ord("^") + | ascii = ord("_") | ascii = ord("~") | ascii = ord("+") + | ascii = ord("-") | ascii = ord(".") | ascii = ord("@") + | ascii = ord("#") end function sexp_nil (pos_l: pos, pos_r: pos): sexp_ast = @@ -369,12 +377,15 @@ let /* Booleans */ ; val end - function sexp_quote (datum: sexp_ast, pos_l: pos, pos_r: pos): sexp_ast = - sexp_pair( sexp_atom( "quote", pos_l, pos_r) + function sexp_wrap (atom: string, datum: sexp_ast, pos_l: pos, pos_r: pos): sexp_ast = + sexp_pair( sexp_atom( atom, pos_l, pos_r) , sexp_pair( datum, sexp_nil(pos_l, pos_r) , pos_l, pos_r) , pos_l, pos_r ) + function sexp_quote (datum: sexp_ast, pos_l: pos, pos_r: pos): sexp_ast = + sexp_wrap("quote", datum, pos_l, pos_r) + function sexp_pair ( car: sexp_ast , cdr: sexp_ast , pos_l: pos @@ -425,20 +436,35 @@ let /* Booleans */ ( ignore_ws() ; if is_symbol(index) then let var start_pos := new_pos(line_number, index) - in while is_symbol(index) + in while index < size(str) & is_symbol(index) do index := index + 1 ; sexp_atom( safe_substring(str, at_char(start_pos), index-1) , start_pos , new_pos(line_number, index - 1) ) end - else if is_tick(index) + else if is_quick_modifier(index) then let var start_pos := new_pos(line_number, index) + var modifier := if is_char("'", index) + then "quote" + else if is_char("`", index) + then "quasiquote" + else if is_char(",", index) + & is_char("@", index+1) + then "unquote-splicing" + else if is_char(",", index) + then "unquote" + else ( parse_error("Internal error: Unknown quick modifier") + ; "SOMETHING FUCKED UP") var datum := ( index := index + 1 + ; if modifier = "unquote-splicing" + then index := index + 1 ; parse_rec() ) - var exp := sexp_quote( datum - , start_pos - , new_pos(line_number, index)) + + var exp := sexp_wrap( modifier + , datum + , start_pos + , new_pos(line_number, index)) in exp end @@ -527,7 +553,7 @@ let /* Booleans */ , most_right ) else sexp end - else (parse_error("Error: I don't even!"); nil)) + else (parse_error("Found no way to progress parsing"); nil)) function parse_error(errmsg: string) = let @@ -749,9 +775,9 @@ let /* Booleans */ if return_now then app_insn(prev_insns, OPCODE_RET, 1, "", pos_l, pos_r) - function tail_position_one (insn: vm_insn, return_now: bool, pos_l: pos, pos_r: pos): vm_insn_list = + function tail_position_one (insn: vm_insn, return_now: bool): vm_insn_list = let var insns := single_insn(insn) - in tail_position(insns, return_now, pos_l, pos_r) + in tail_position(insns, return_now, insn.pos_l, insn.pos_r) ; insns end @@ -1018,15 +1044,21 @@ let /* Booleans */ , base_env ) function env_seek_elem(env: vm_env, key: string): vm_env = - let var head := env - in while head <> nil + let function valid_head (head: vm_env): bool = + head <> nil & head.typ <> type_nil - & head.val_car.val_car.val_s <> key + /*& head.val_car <> nil + & head.val_car.typ = type_pair + & head.val_car.val_car.typ = type_string*/ + var head := env + + in while valid_head(head) + & head.val_car.val_car.val_s <> key do head := head.val_cdr - ; if head <> nil - & head.typ <> type_nil - then head + ; if valid_head(head) + & head.val_car.val_car.val_s = key + then head else nil end @@ -1316,6 +1348,78 @@ let /* Booleans */ , ast) ; list(nil)) + function compile_quasiquote (datum: sexp_ast): vm_insn_list = + if datum = nil + then ( compile_error("Internal error: Bad quasiquote", datum) + ; nil ) + + else if datum.typ <> type_pair + then nil + + else if datum.val_car.typ = type_symbol + & datum.val_car.val_s = "unquote" + then if datum.val_cdr.typ <> type_pair + & datum.val_cdr.val_cdr.typ <> type_nil + then ( compile_error("Incorrect form of unquote", datum) + ; nil ) + else compile_rec(datum.val_cdr.val_car, false) + + else if datum.val_car.typ = type_pair + & datum.val_car.val_car.typ = type_symbol + & datum.val_car.val_car.val_s = "unquote-splicing" + then if datum.val_car.val_cdr.typ <> type_pair + & datum.val_car.val_cdr.val_cdr.typ <> type_nil + then ( compile_error("Incorrect form of unquote-splicing", datum) + ; nil ) + else let var insns := list(nil) + var insns_car := compile_rec(datum.val_car.val_cdr.val_car, false) + var insns_cdr := compile_quasiquote(datum.val_cdr) + in if insns_cdr = nil + then insns_cdr := + single_insn ( vm_insn { opcode = OPCODE_PUSH + , arg1 = 0 + , arg2 = "" + , arg3 = datum.val_cdr + , pos_l = datum.val_cdr.pos_l + , pos_r = datum.val_cdr.pos_r } ) + /* TODO: Below method to call append is risky */ + ; app_insn(insns, OPCODE_LOAD, 0, "append", datum.pos_l, datum.pos_r) + ; concat_lists(insns, insns_car) + ; concat_lists(insns, insns_cdr) + ; app_insn(insns, OPCODE_CALL, 2, "", datum.pos_l, datum.pos_r) + ; insns + end + + else if datum.val_car.typ = type_symbol + & datum.val_car.val_s = "quasiquote" + then ( compile_error("TODO: Nested quasiquote", datum) + ; nil ) + + else + let var insns_car := compile_quasiquote(datum.val_car) + var insns_cdr := compile_quasiquote(datum.val_cdr) + in if insns_car = nil & insns_cdr <> nil + then insns_car := + single_insn ( vm_insn { opcode = OPCODE_PUSH + , arg1 = 0 + , arg2 = "" + , arg3 = datum.val_car + , pos_l = datum.val_car.pos_l + , pos_r = datum.val_car.pos_r } ) + ; if insns_car <> nil & insns_cdr = nil + then insns_cdr := + single_insn ( vm_insn { opcode = OPCODE_PUSH + , arg1 = 0 + , arg2 = "" + , arg3 = datum.val_cdr + , pos_l = datum.val_cdr.pos_l + , pos_r = datum.val_cdr.pos_r } ) + ; if insns_car = nil & insns_cdr = nil + then nil + else ( concat_lists(insns_car, insns_cdr) + ; app_insn(insns_car, OPCODE_CONS, 0, "", datum.pos_l, datum.pos_r) + ; insns_car ) + end function compile_rec (ast: sexp_ast, can_tail_call: int): vm_insn_list = if ast = nil then nil @@ -1329,7 +1433,7 @@ let /* Booleans */ /* Handle numbers and other constants */ else if ast.typ <> type_pair then tail_position_one( atom_to_insn(ast, ast.pos_l, ast.pos_r) - , can_tail_call, ast.pos_l, ast.pos_r ) + , can_tail_call) /* If statements */ else if ast.val_car <> nil @@ -1389,9 +1493,23 @@ let /* Booleans */ , arg3 = datum , pos_l = ast.pos_l , pos_r = ast.pos_r } - , can_tail_call - , ast.pos_l - , ast.pos_r) + , can_tail_call) + end + + /* Quasi-Quote expressions */ + else if ast.val_car <> nil & ast.val_car.val_s = "quasiquote" + then let var datum := ast.val_cdr.val_car + var insns := compile_quasiquote(datum) + + in if insns = nil + then insns := single_insn(vm_insn { opcode = OPCODE_PUSH + , arg1 = 0 + , arg2 = "" + , arg3 = datum + , pos_l = ast.pos_l + , pos_r = ast.pos_r }) + ; tail_position(insns, can_tail_call, ast.pos_l, ast.pos_r) + ; insns end /* Set statements */ @@ -1444,6 +1562,7 @@ let /* Booleans */ /* Macro applications */ else if ast.val_car <> nil & ast.val_car.typ = type_symbol + & ast.val_car.val_s <> "" & env_seek_elem(env_macro, ast.val_car.val_s) <> nil then let var stack := stack_new() var env_elem := env_seek_elem(env_macro, ast.val_car.val_s) @@ -1453,10 +1572,17 @@ let /* Booleans */ ; print(value_to_string(fun)) ; print(" as macro\n")*/ ; if fun <> nil & fun.typ <> type_closure - then compile_error("Attempting to use non-function as macro function.", ast) - ; vm_run(macro_tape, fun.val_i, stack, fun.val_car, "", env_global) - /* TODO: Assert that there is something on the stack */ - ; compile_rec(stack_pop(stack), can_tail_call) + then ( compile_error(concat5( "Attempting to use non-function " + , value_to_string(fun) + , " refered to as \"" + , ast.val_car.val_s + , "\", as macro function.") + , ast) + ; TRIGGERED_EXIT := true + ; nil ) + else ( vm_run(macro_tape, fun.val_i, stack, fun.val_car, "", env_global) + /* TODO: Assert that there is something on the stack */ + ; compile_rec(stack_pop(stack), can_tail_call) ) end /* Call expressions */ @@ -1947,9 +2073,10 @@ in print("Ready for the scheming Tiger?\n") var insns := compile_to_vm(sexp_compile, env_macro, tape, env_global) var start_index := tape_append(tape, insns) in () - /*print("Parsed: ") - ; print(value_to_string(sexp)) - ; print("\n") */ + ; if DEBUG_PRINT_PARSED + then ( print("Parsed: ") + ; print(value_to_string(sexp)) + ; print("\n")) ; if DEBUG_PRINT_TAPE then ( print("Tape:\n")