diff --git a/example.scm b/example.scm index a8fb2b7..a1c0804 100644 --- a/example.scm +++ b/example.scm @@ -1,4 +1,52 @@ +;;; Standard lib, in scheme + +; Lists + +; +(define (foldl f i l) + (if (null? l) + i + (foldl f (f (car l) i) (cdr l)))) + +(define (foldr f i l) + (if (null? l) + i + (f (car l) (foldr f i (cdr l))))) + +(define (map f l) + (if (null? l) + '() + (foldr (lambda (e a) (cons (f e) a)) '() l))) + +(define (length l) + (foldl + 0 (map (lambda (x) 1) l))) + +(define (reverse l) + (foldl cons '() l)) + + +(define list-tail; Taken from https://people.csail.mit.edu/jaffer/r5rs/Pairs-and-lists.html + (lambda (x k) + (if (zero? k) + x + (list-tail (cdr x) (- k 1))))) + + + +; Math + +(define (zero? x) (= x 0)) +(define (positive? x) (> x 0)) +(define (negative? x) (< x 0)) +(define (odd? x) (= (mod x 2) 1)) +(define (even? x) (= (mod x 2) 0)) + + +; Test string + +(display "Hello World") (newline) + ; Test functions (define add-three (lambda (x y z) (+ (+ x z) y))) @@ -31,6 +79,70 @@ (set! x 10) (display x) (newline) +(newline) +(display "* R5RS: Testing numerical operators *") +(newline) + +(display "Testing number?\n\tExpect: #t #f #f #f\n\tGotten: ") +(display (number? 5)) +(display " ") +(display (number? #f)) +(display " ") +(display (number? "hello")) +(display " ") +(display (number? '(1 2))) +(newline) + +(newline) +(display "* R5RS: Testing fold and map *") +(newline) + +(display "Testing sum over foldl!\n\tExpect: 28\n\tGotten: ") +(display (foldl + 0 '(1 2 3 4 5 6 7))) +(newline) + +(display "Testing sum over foldr!\n\tExpect: 28\n\tGotten: ") +(display (foldr + 0 '(1 2 3 4 5 6 7))) +(newline) + +(display "Testing map!\n\tExpect: (21 22 23)\n\tGotten: ") +(display (map (lambda (a) (+ 20 a)) '(1 2 3))) +(newline) + +(display "Testing length!\n\tExpect: 13\n\tGotten: ") +(display (length '(1 2 3 1 2 3 1 2 3 1 2 3 1))) +(newline) + +(display "Testing length!\n\tExpect: (5 4 3 2 1)\n\tGotten: ") +(display (reverse '(1 2 3 4 5))) +(newline) + +; Test environment set + +(newline) +(display "* Testing custom library *") +(newline) + +(display "Testing set-env! Expect 32: ") +(display ((set-env! (lambda () x) '((x . 32)) ))) +(newline) + +(display "Testing string->datum! Expect (2): ") +(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 syntax-rules (define-syntax and diff --git a/tigerscheme.tig b/tigerscheme.tig index fe458a2..0a7dff1 100644 --- a/tigerscheme.tig +++ b/tigerscheme.tig @@ -11,16 +11,25 @@ let /* Booleans */ var HAS_NIL_SYMBOL : bool := false var DEBUG_PRINT_STACK : bool := false - /* Basic utility */ - function concatm ( s1: string + function concat5 ( s1: string , s2: string , s3: string , s4: string , s5: string ): string = concat(s1, concat(s2, concat(s3, concat(s4, s5)))) + function concat8 ( s1: string + , s2: string + , s3: string + , s4: string + , s5: string + , s6: string + , s7: string + , s8: string ): string = + concat(s1, concat(s2, concat(s3, concat(s4, concat(s5, concat(s6, concat(s7, s8))))))) + function string_to_unsigned_int (str: string): int = let var value := 0 in for i := 0 to size(str) - 1 @@ -59,6 +68,25 @@ let /* Booleans */ ; i_end := min(size(str) - 1, i_end) ; substring(str, i_start, i_end - i_start + 1) ) + /* Source positioning */ + + type pos = { at_char: int, line_num: int } + function new_pos (line_num: int, at_char: int): pos = + pos { at_char = at_char, line_num = line_num } + function line_num (pos: pos): int = pos.line_num + function at_char (pos: pos): int = pos.at_char + function pos_delta_char (pos: pos, delta: int): pos = + new_pos( line_num(pos) + , at_char (pos) + delta) + + var pos_unknown: pos := nil + + function pos_to_string (pos: pos): string = + if pos = pos_unknown + then "unknown position" + else + concat("line ", int_to_string(line_num(pos))) + /* Scheme value system */ type type_type = int @@ -66,16 +94,15 @@ let /* Booleans */ type scheme_value = { typ : type_type , val_i : int , val_s : string - , val_e : scheme_environment , val_car : scheme_value , val_cdr : scheme_value - , pos_l: int - , pos_r: int } + , pos_l: pos + , pos_r: pos } - type vm_env_key = string + type vm_env_key = scheme_value type vm_env_elem = scheme_value - type vm_env = { key: vm_env_key, value: vm_env_elem, next: vm_env } + type vm_env = scheme_value type scheme_environment = vm_env var type_integer := 0 @@ -87,12 +114,35 @@ let /* Booleans */ var type_true := 6 var type_pair := 7 + function error_value_to_string(v: scheme_value): string = + if v = nil + then "" + else + let + in concat8( " 0 + then concat("; I = ", int_to_string(v.val_i)) + else "" + , if v.val_s <> "" + then concat("; S = ", (v.val_s)) + else "" + , if v.val_car <> nil + then concat("; CAR = ", value_to_string(v.val_car)) + else "" + , if v.val_cdr <> nil + then concat("; CDR = ", value_to_string(v.val_cdr)) + else "" + , "" + , ">") + end + function value_to_string (base_v: scheme_value): string = let function val_rec (v : scheme_value , req_paren : bool): string = if v = nil then ( print("Error in value_to_string: Got nil value.\n") - ; "" ) + ; error_value_to_string(v) ) else if v.typ = type_integer then int_to_string(v.val_i) @@ -114,9 +164,12 @@ let /* Booleans */ else if v.typ = type_true then "#t" - else if v.typ = type_pair & v.val_cdr.typ = type_nil + else if v.typ = type_pair & v.val_cdr = nil + then error_value_to_string(v) + + else if v.typ = type_pair & v.val_cdr <> nil & v.val_cdr.typ = type_nil then let - in concatm ( if req_paren then "(" else "" + in concat5 ( if req_paren then "(" else "" , val_rec(v.val_car, true) , if req_paren then ")" else "" , "" @@ -124,8 +177,9 @@ let /* Booleans */ end else if v.typ = type_pair - then let var is_real := v.val_cdr.typ = type_pair - in concatm ( if req_paren then "(" else "" + then let var is_real := v.val_cdr <> nil + & v.val_cdr.typ = type_pair + in concat5 ( if req_paren then "(" else "" , val_rec(v.val_car, true) , if is_real then " " else " . " , val_rec(v.val_cdr, not(is_real)) @@ -133,7 +187,7 @@ let /* Booleans */ end else ( print("Error in value_to_string: Unknown type.\n") - ; "" ) + ; error_value_to_string(v) ) in val_rec(base_v, true) end @@ -161,82 +215,87 @@ let /* Booleans */ scheme_value { typ = type_integer , val_i = i , val_s = "" - , val_e = nil , val_car = nil , val_cdr = nil - , pos_l = -1 - , pos_r = -1 } + , pos_l = pos_unknown + , pos_r = pos_unknown } function str_val (s: string): scheme_value = scheme_value { typ = type_string , val_i = 0 , val_s = s - , val_e = nil , val_car = nil , val_cdr = nil - , pos_l = -1 - , pos_r = -1 } + , pos_l = pos_unknown + , pos_r = pos_unknown } function fun_val (i: int, env: scheme_environment): scheme_value = scheme_value { typ = type_closure , val_i = i , val_s = "" - , val_e = env - , val_car = nil + , val_car = env , val_cdr = nil - , pos_l = -1 - , pos_r = -1 } + , pos_l = pos_unknown + , pos_r = pos_unknown } - function bool_val (i: int): scheme_value = - scheme_value { typ = if (i <> 0) - then type_true - else type_false - , val_i = i <> 0 + var VAL_TRUE := + scheme_value { typ = type_true + , val_i = 1 , val_s = "" - , val_e = nil , val_car = nil , val_cdr = nil - , pos_l = -1 - , pos_r = -1 } + , pos_l = pos_unknown + , pos_r = pos_unknown } + + var VAL_FALSE := + scheme_value { typ = type_false + , val_i = 0 + , val_s = "" + , val_car = nil + , val_cdr = nil + + , pos_l = pos_unknown + , pos_r = pos_unknown } + + function bool_val (i: int): scheme_value = + if (i <> 0) then VAL_TRUE + else VAL_FALSE function pair_val (car: scheme_value, cdr: scheme_value): scheme_value = scheme_value { typ = type_pair , val_i = 0 , val_s = "" - , val_e = nil , val_car = car , val_cdr = cdr - , pos_l = -1 - , pos_r = -1 } + , pos_l = pos_unknown + , pos_r = pos_unknown } function sym_val (sym: string): scheme_value = scheme_value { typ = type_symbol , val_i = 0 , val_s = sym - , val_e = nil , val_car = nil , val_cdr = nil - , pos_l = -1 - , pos_r = -1 } + , pos_l = pos_unknown + , pos_r = pos_unknown } function nil_val (): scheme_value = scheme_value { typ = type_nil , val_i = 0 , val_s = "" - , val_e = nil , val_car = nil , val_cdr = nil - , pos_l = -1 - , pos_r = -1 } + , pos_l = pos_unknown + , pos_r = pos_unknown } var VALUE_UNSPECIFIED := nil_val() @@ -245,33 +304,25 @@ let /* Booleans */ type sexp_ast = scheme_value function parse_string (str: string): sexp_ast = - let var index := 0 + let var index := 0 + var line_number := 1 + + function is_char (char: string, index: int): bool = + let var ascii := ord(substring(str, index, 1)) + in ascii = ord(char) + end + + 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_ws (index: int): int = let var ascii := ord(substring(str, index, 1)) in ascii = 32 | ascii = 9 | ascii = 10 end - function is_left_paren (index: int): int = - let var ascii := ord(substring(str, index, 1)) - in ascii = 40 - end - - function is_right_paren (index: int): int = - let var ascii := ord(substring(str, index, 1)) - 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("'") - end - function is_symbol (index: int): int = let var ascii := ord(substring(str, index, 1)) in not ( ascii = 9 @@ -279,20 +330,21 @@ let /* Booleans */ | ascii = 32 | ascii = 40 | ascii = 41 - | ascii = ord("'") ) + | ascii = ord("\"") + | ascii = ord("'") + | ascii = ord(";") ) end - function sexp_nil (pos_l: int, pos_r: int): sexp_ast = + function sexp_nil (pos_l: pos, pos_r: pos): sexp_ast = sexp_ast { typ = type_nil , val_i = 0 , val_s = "" - , val_e = nil , val_car = nil , val_cdr = nil , pos_l = pos_l , pos_r = pos_r } - function sexp_atom (sym: string, pos_l: int, pos_r: int): sexp_ast = + function sexp_atom (sym: string, pos_l: pos, pos_r: pos): sexp_ast = let var val := if sym = "#f" then bool_val(0) else if sym = "#t" @@ -305,7 +357,7 @@ let /* Booleans */ ; val end - function sexp_quote (datum: sexp_ast, pos_l: int, pos_r: int): sexp_ast = + function sexp_quote (datum: sexp_ast, pos_l: pos, pos_r: pos): sexp_ast = sexp_pair( sexp_atom( "quote", pos_l, pos_r) , sexp_pair( datum, sexp_nil(pos_l, pos_r) , pos_l, pos_r) @@ -313,21 +365,42 @@ let /* Booleans */ function sexp_pair ( car: sexp_ast , cdr: sexp_ast - , pos_l: int - , pos_r: int): sexp_ast = + , pos_l: pos + , pos_r: pos): sexp_ast = sexp_ast { typ = type_pair , val_i = 0 , val_s = "" - , val_e = nil , val_car = car , val_cdr = cdr , pos_l = pos_l , pos_r = pos_r } + function sexp_string ( str: string + , pos_l: pos + , pos_r: pos): sexp_ast = + sexp_ast { typ = type_string + , val_i = 0 + , val_s = str + , val_car = nil + , val_cdr = nil + , pos_l = pos_l + , pos_r = pos_r } + function ignore_ws () = + /* Do nothing when outside string */ + if index >= size(str) + then () + + /* Handle newline */ + else if is_char("\n", index) + then ( line_number := line_number + 1 + ; index := index + 1 + ; ignore_ws() ) + /* Ignore whitespace */ - if index < size(str) & is_ws(index) - then (index := index + 1; ignore_ws()) + else if index < size(str) & is_ws(index) + then ( index := index + 1 + ; ignore_ws() ) /* Handle comments, ignore until newline */ else if is_comment_start(index) @@ -339,34 +412,62 @@ let /* Booleans */ function parse_rec (): sexp_ast = ( ignore_ws() ; if is_symbol(index) - then let var index_start := index + then let var start_pos := new_pos(line_number, index) in while is_symbol(index) do index := index + 1 - ; sexp_atom( substring(str, index_start, index - index_start) - , index_start - , 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) - then let var index_start := index + then let var start_pos := new_pos(line_number, index) var datum := ( index := index + 1 ; parse_rec() ) - var exp := sexp_quote(datum, index_start, index) + var exp := sexp_quote( datum + , start_pos + , new_pos(line_number, index)) in exp end + else if is_goose_marks(index) + then let var start_pos := new_pos(line_number, index) + var string_str := "" + function app_str (new_str: string) = + string_str := concat(string_str, new_str) + /* TODO: Implement escape codes */ + + in index := index + 1 + ; while not(is_goose_marks(index)) & index < size(str) + do if is_char("\\", index) /*" Gotta love bad syntax files */ + then ( if is_char("n", index+1) + then app_str("\n") + else if is_char("t", index+1) + then app_str("\t") + else print("Unknown escape code in string") + ; index := index + 2 ) + else ( app_str(substring(str, index, 1)) + ; index := index + 1 ) + + ; index := index + 1 + ; sexp_string( string_str + , start_pos + , new_pos(line_number, index-1)) + end + else if is_left_paren(index) then let var sexp : sexp_ast := nil var sexp_last : sexp_ast := nil - var index_start := index - var most_right := index + var start_pos : pos := new_pos(line_number, index) + var most_right: pos := start_pos in index := index + 1 /* Position after index */ ; while index < size(str) & not(is_right_paren(index)) do let var parsed := parse_rec() + var pos := new_pos(line_number, index) var link := sexp_pair( parsed - , sexp_nil(index, index) + , sexp_nil(pos, pos) , parsed.pos_l , parsed.pos_r ) @@ -388,17 +489,15 @@ let /* Booleans */ * parsing */ else ( sexp_last.val_cdr := link ; sexp_last := sexp_last.val_cdr ) - ; most_right := max(link.pos_r, most_right) + ; most_right := if at_char(link.pos_r) > at_char(most_right) + then link.pos_r + else most_right ; ignore_ws() end /* Error handling */ ; if index >= size(str) then parse_error("Misaligned parenthesis") - /*else if index = index_start + 1 - then parse_error("Encountered unit - expression (); is not allowed - Scheme.")*/ /* Give correct positions */ ; sexp_last := sexp @@ -406,13 +505,14 @@ let /* Booleans */ do ( sexp_last.pos_r := most_right ; sexp_last := sexp_last.val_cdr ) ; if sexp <> nil - then ( sexp.pos_l := sexp.pos_l - 1 - ; sexp.pos_r := sexp.pos_r + 1 ) + then ( sexp.pos_l := pos_delta_char(sexp.pos_l, -1) + ; sexp.pos_r := pos_delta_char(sexp.pos_r, 1)) /* Continue with stuff */ ; index := index + 1 ; if sexp = nil - then sexp_nil(index_start, most_right) + then sexp_nil( start_pos + , most_right ) else sexp end else (parse_error("Error: I don't even!"); nil)) @@ -463,11 +563,13 @@ let /* Booleans */ , arg1: int , arg2: string , arg3: scheme_value - , pos_l: int - , pos_r: int } + , pos_l: pos + , pos_r: pos } type vm_tape_tape = array of vm_insn - type vm_tape = { length: int, tape: vm_tape_tape } + type vm_tape = { length: int + , filled: int + , tape: vm_tape_tape } type vm_insn_info = { opcode : int , mnemonic : string @@ -500,6 +602,9 @@ let /* Booleans */ var OPCODE_SET := 21 var OPCODE_FRSTR := 22 var OPCODE_COMPILE:= 23 + var OPCODE_SETENV := 24 + var OPCODE_NUMEQ := 25 + var OPCODE_TYPEOF := 26 var vm_insn_num_opcodes := 0 var vm_insn_info := @@ -511,7 +616,7 @@ let /* Booleans */ , uses_arg2 : int , uses_arg3 : int ) = ( if a[opcode] <> nil - then print(concatm( "Error: Overwriting previously defined opcode information!\n Opcode: " + then print(concat5( "Error: Overwriting previously defined opcode information!\n Opcode: " , int_to_string(opcode) , " with previous mnenomic " , a[opcode].mnemonic @@ -540,7 +645,10 @@ let /* Booleans */ ; code(OPCODE_SETG, "SETG", 0, 1, 0) ; code(OPCODE_DEFFUN, "DEFFUN", 1, 0, 0) ; code(OPCODE_POP, "POP", 0, 0, 0) + ; code(OPCODE_GEQ, "GEQ", 0, 0, 0) + ; code(OPCODE_NUMEQ, "NUMEQ", 0, 0, 0) + ; code(OPCODE_TYPEOF, "TYPEOF", 0, 0, 0) ; code(OPCODE_CONS, "CONS", 0, 0, 0) ; code(OPCODE_CAR, "CAR", 0, 0, 0) @@ -551,11 +659,12 @@ let /* Booleans */ ; code(OPCODE_TOSTR, "TOSTR", 0, 0, 0) ; code(OPCODE_FRSTR, "FRSTR", 0, 0, 0) - ; code(OPCODE_COMPILE,"COMPILE", 0, 0, 0) + ; code(OPCODE_COMPILE,"COMPILE", 0, 0, 0) + ; code(OPCODE_SETENV, "SETENV", 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 " + then print(concat5("Error: Opcode info array incorrectly initialized!\n Opcode " , int_to_string(i) , " is declared, but " , int_to_string(i-1) @@ -569,7 +678,7 @@ let /* Booleans */ ; a end - function noop_insn (pos_l: int, pos_r: int): vm_insn = + function noop_insn (pos_l: pos, pos_r: pos): vm_insn = vm_insn { opcode = OPCODE_DGOTO , arg1 = 1 , arg2 = "" @@ -582,13 +691,32 @@ 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 tape_new (init_size: int): vm_tape = + vm_tape { length = init_size + , filled = 0 + , tape = vm_tape_tape [init_size] of nil } + + function tape_append(tape: vm_tape, new_insns: vm_insn_list): int = + let var head := new_insns.first + var index_start := tape.filled + var index := index_start + var real_tape := tape.tape + /* TODO: Ensure enough space on tape for new additions. */ + in while head <> nil + do ( real_tape[index] := head.insn + ; index := index + 1 + ; head := head.next ) + ; tape.filled := index + ; index_start + end + function concat_lists (a: vm_insn_list, b: vm_insn_list): vm_insn_list = ( if a = nil then print("Error: Impossible concat\n") else if b = nil | b.first = nil then () else if (a.first = nil & a.last <> nil) | (a.first <> nil & a.last = nil) - then print(concatm( "Error: Instruction list invariant not maintained! First is " + then print(concat5( "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 " @@ -605,7 +733,7 @@ let /* Booleans */ in vm_insn_list { first = link, last = link } end - function app_insn (insns: vm_insn_list, opcode:int, arg1: int, arg2: string, pos_l: int, pos_r: int) = + function app_insn (insns: vm_insn_list, opcode:int, arg1: int, arg2: string, pos_l: pos, pos_r: pos) = ( concat_lists(insns, single_insn(vm_insn { opcode = opcode , arg1 = arg1 , arg2 = arg2 @@ -614,7 +742,7 @@ let /* Booleans */ , pos_r = pos_r })) ; ()) - function app_insn2 (insns: vm_insn_list, opcode:int, arg3: scheme_value, pos_l: int, pos_r: int) = + function app_insn2 (insns: vm_insn_list, opcode:int, arg3: scheme_value, pos_l: pos, pos_r: pos) = ( concat_lists(insns, single_insn(vm_insn { opcode = opcode , arg1 = 0 , arg2 = "" @@ -623,11 +751,11 @@ let /* Booleans */ , pos_r = pos_r })) ; ()) - function tail_position (prev_insns: vm_insn_list, return_now: bool, pos_l: int, pos_r: int) = + function tail_position (prev_insns: vm_insn_list, return_now: bool, pos_l: pos, pos_r: pos) = 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: int, pos_r: int): vm_insn_list = + function tail_position_one (insn: vm_insn, return_now: bool, pos_l: pos, pos_r: pos): vm_insn_list = let var insns := single_insn(insn) in tail_position(insns, return_now, pos_l, pos_r) ; insns @@ -643,23 +771,23 @@ let /* Booleans */ end - var STD_LIB_ENV: vm_env := nil + var ENV_EMPTY : vm_env := nil_val() + var ENV_STD : vm_env := ENV_EMPTY var STD_LIB_ID_FUNCTION: scheme_value := nil - var STD_LIB := let var first_insn := noop_insn(-1, -1) + var STD_LIB := let var first_insn := noop_insn(pos_unknown, pos_unknown) var std_insns := single_insn(first_insn) function app (opcode: int, arg1: int, arg2: string) = - app_insn(std_insns, opcode, arg1, arg2, -1, -1) + app_insn(std_insns, opcode, arg1, arg2, pos_unknown, pos_unknown) function app2 (opcode: int, arg3: scheme_value) = - app_insn2(std_insns, opcode, arg3, -1, -1) + app_insn2(std_insns, opcode, arg3, pos_unknown, pos_unknown) function stdval (name: string, value: scheme_value) = - STD_LIB_ENV := vm_env { key = name - , value = value - , next = STD_LIB_ENV } + ENV_STD := pair_val( pair_val( sym_val(name), value) + , ENV_STD ) function tape_pos (): int = insn_list_length(std_insns) @@ -677,18 +805,13 @@ let /* Booleans */ ; STD_LIB_ID_FUNCTION := fun_val(tape_pos(), nil) ; app(OPCODE_RET, 1, "") - /* Useful standard functions */ - ; stdfun("display") - ; app(OPCODE_TOSTR, 0, "") - ; app(OPCODE_OUTPUT, 0, "") - ; app2(OPCODE_PUSH, VALUE_UNSPECIFIED) - ; app(OPCODE_RET, 1, "") + /* R5RS: Pairs and Lists */ - ; stdfun("newline") - ; app2(OPCODE_PUSH, str_val("\n")) - ; app(OPCODE_OUTPUT, 0, "") - ; app2(OPCODE_PUSH, VALUE_UNSPECIFIED) - ; app(OPCODE_RET, 1, "") + ; stdfun("pair?") + ; app(OPCODE_TYPEOF, 0, "") + ; app2(OPCODE_PUSH, int_val(type_pair)) + ; app(OPCODE_NUMEQ, 0, "") + ; app(OPCODE_RET, 1, "") ; stdfun("cons") ; app(OPCODE_CONS, 0, "") @@ -702,12 +825,136 @@ let /* Booleans */ ; app(OPCODE_CDR, 0, "") ; app(OPCODE_RET, 1, "") + /* TODO: set-car! set-cdr! caar ... cddddr */ + + ; stdfun("null?") + ; app(OPCODE_TYPEOF, 0, "") + ; app2(OPCODE_PUSH, int_val(type_nil)) + ; app(OPCODE_NUMEQ, 0, "") + ; app(OPCODE_RET, 1, "") + + /* R5RS: Numerical Operations */ + /* TODO: Support more than integers */ + + ; stdfun("number?") + ; stdfun("complex?") + ; stdfun("real?") + ; stdfun("rational?") + ; stdfun("integer?") + ; app(OPCODE_TYPEOF, 0, "") + ; app2(OPCODE_PUSH, int_val(type_integer)) + ; app(OPCODE_NUMEQ, 0, "") + ; app(OPCODE_RET, 1, "") + + ; stdfun("exact?") + ; app(OPCODE_POP, 0, "") + ; app2(OPCODE_PUSH, VAL_TRUE) + ; app(OPCODE_RET, 1, "") + + ; stdfun("inexact?") + ; app(OPCODE_POP, 0, "") + ; app2(OPCODE_PUSH, VAL_FALSE) + ; app(OPCODE_RET, 1, "") + + ; stdfun("+") + ; app(OPCODE_ADD, 0, "") + ; app(OPCODE_RET, 1, "") + + ; stdfun("*") + ; app(OPCODE_MULT, 0, "") + ; app(OPCODE_RET, 1, "") + + ; stdfun(">=") + ; app(OPCODE_GEQ, 0, "") + ; app(OPCODE_RET, 1, "") + + ; stdfun("<=") + ; app(OPCODE_SWITCH, 0, "") + ; app(OPCODE_GEQ, 0, "") + ; app(OPCODE_RET, 1, "") + + /* TODO: =, <, > */ + + /* Defined in scheme: + - zero? + - positive? + - negative? + - odd? + - even? + */ + ; stdfun("zero?") + ; app2(OPCODE_PUSH, int_val(0)) + ; app(OPCODE_NUMEQ, 0, "") + ; app(OPCODE_RET, 1, "") + + /* TODO: Rest */ + + + /* R5RS: Output */ + + ; stdfun("display") + ; app(OPCODE_DUPL, 0, "") + ; app(OPCODE_TYPEOF, 0, "") + ; app2(OPCODE_PUSH, int_val(type_string)) + ; app(OPCODE_NUMEQ, 0, "") + ; app(OPCODE_CSKIP, 0, "") + ; app(OPCODE_DGOTO, 2, "") + ; app(OPCODE_TOSTR, 0, "") + ; app(OPCODE_OUTPUT, 0, "") + ; app2(OPCODE_PUSH, VALUE_UNSPECIFIED) + ; app(OPCODE_RET, 1, "") + + ; stdfun("write") + ; app(OPCODE_TOSTR, 0, "") + ; app(OPCODE_OUTPUT, 0, "") + ; app2(OPCODE_PUSH, VALUE_UNSPECIFIED) + ; app(OPCODE_RET, 1, "") + + ; stdfun("newline") + ; app2(OPCODE_PUSH, str_val("\n")) + ; app(OPCODE_OUTPUT, 0, "") + ; app2(OPCODE_PUSH, VALUE_UNSPECIFIED) + ; app(OPCODE_RET, 1, "") + + /* TODO: write-char */ + + /* R5RS: Other */ + + ; stdfun("eval") + ; app(OPCODE_SWITCH, 0, "") + ; app(OPCODE_COMPILE, 0, "") + ; app(OPCODE_SETENV, 0, "") + ; app(OPCODE_RET, 0, "") + + ; stdfun("null-environment") + /* Signal error on unknown environment version */ + ; app(OPCODE_POP, 0, "") + ; app2(OPCODE_PUSH, ENV_EMPTY) + ; app(OPCODE_RET, 1, "") + + ; stdfun("scheme-report-environment") + ; stdfun("interaction-environment") + /* Signal error on unknown environment version */ + ; app(OPCODE_POP, 0, "") + ; app2(OPCODE_PUSH, ENV_STD) /* Defined R5RS environement */ + ; app(OPCODE_RET, 1, "") + + /* Personal implementation functions */ + ; stdfun("string->datum") + ; app(OPCODE_FRSTR, 0, "") + ; app(OPCODE_RET, 1, "") + + ; stdfun("set-env!") + ; app(OPCODE_SWITCH, 0, "") + ; app(OPCODE_SETENV, 0, "") + ; app(OPCODE_RET, 1, "") + ; first_insn.arg1 := insn_list_length(std_insns) ; std_insns end - function compile_to_vm (ast: sexp_ast): vm_tape = + function compile_to_vm (ast: sexp_ast): vm_insn_list = let function list (head: vm_insn_list_link): vm_insn_list = let var tail := head in while tail <> nil & tail.next <> nil @@ -718,7 +965,7 @@ let /* Booleans */ function copy_list (ls: vm_insn_list): vm_insn_list = list(ls.first) - function atom_to_insn (sym: scheme_value, pos_l: int, pos_r: int): vm_insn = + function atom_to_insn (sym: scheme_value, pos_l: pos, pos_r: pos): vm_insn = if sym = nil then ( print("Error in atom_to_list: Got nil as sym!\n") ; nil ) @@ -736,36 +983,6 @@ let /* Booleans */ , pos_l = pos_l , pos_r = pos_r } - function is_postfix (ast: sexp_ast): int = - (ast <> nil) - & (ast.typ = type_pair) - & (ast.val_car <> nil) - & (ast.val_car.typ <> type_pair) - & (ast.val_car.val_s = "+" | ast.val_car.val_s = "*" | ast.val_car.val_s = ">=") - - function op_insn (opcode: int, pos_l: int, pos_r: int): vm_insn = - vm_insn { opcode = opcode - , arg1 = 0 - , arg2 = "" - , arg3 = nil - , pos_l = pos_l - , pos_r = pos_r } - - function compile_postfix ( sym : string - , num_args : int - , insns : vm_insn_list - , pos_l : int - , pos_r : int - , tail_call: bool ): vm_insn_list = - let var insn := if sym = "+" then op_insn(OPCODE_ADD, pos_l, pos_r) - else if sym = "*" then op_insn(OPCODE_MULT, pos_l, pos_r) - else if sym = ">=" then op_insn(OPCODE_GEQ, pos_l, pos_r) - else (print("Unknown special form"); nil) - - in concat_lists(insns, single_insn(insn)) - ; tail_position(insns, tail_call, pos_l, pos_r) - ; insns - end function sexp_ast_length(insns: vm_insn_list): int = let function rec (insns: vm_insn_list_link, sum: int): int = @@ -775,8 +992,8 @@ let /* Booleans */ end function set_tree_positions ( ast: sexp_ast - , pos_l: int - , pos_r: int ) = + , pos_l: pos + , pos_r: pos ) = /* Useful for setting the positions of generated AST. */ if ast <> nil then ( ast.pos_l := pos_l @@ -943,7 +1160,7 @@ let /* Booleans */ in if sexp_is_syntax_rules(ast) then compile_rec(STD_LIB_ID_FUNCTION, false) else ( compile_error("Syntax of syntax-rules usage is incorrect.", ast) - ; compile_rec(VALUE_UNSPECIFIED, false) ) + ; single_insn(atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r)) ) end function compile_define_syntax (ast: sexp_ast): vm_insn_list = @@ -1144,45 +1361,35 @@ let /* Booleans */ do ( concat_lists(args_insns, compile_rec(ast_iter.val_car, false)) ; num_args := num_args + 1 ; ast_iter := ast_iter.val_cdr ) - ; if is_postfix(ast) - then compile_postfix (ast.val_car.val_s, num_args, args_insns, pos_l, pos_r, can_tail_call) - else let - var insns_head := compile_rec(ast.val_car, false) - /* Below we choose whether to call - * normally, or tail calling (identical - * to returning) */ - var call_op := if can_tail_call - then OPCODE_RET - else OPCODE_CALL - in concat_lists( insns_head, args_insns) - ; app_insn( insns_head, call_op, num_args, "", pos_l, pos_r) - ; insns_head - end + ; let var insns_head := compile_rec(ast.val_car, false) + /* Below we choose whether to call + * normally, or tail calling (identical + * to returning) */ + var call_op := if can_tail_call + then OPCODE_RET + else OPCODE_CALL + in concat_lists( insns_head, args_insns) + ; app_insn( insns_head, call_op, num_args, "", pos_l, pos_r) + ; insns_head + end end function compile_error(errmsg: string, errast: sexp_ast) = - let + let var repr_pos_l := pos_to_string(errast.pos_l) + var repr_pos_r := pos_to_string(errast.pos_r) in print("Tiger-scheme compile error\n ") ; print(errmsg) ; print("\n For scheme: ") ; print(value_to_string(errast)) + ; print("\n Source pos: ") + ; print(repr_pos_l) + ; if repr_pos_l <> repr_pos_r + then ( print(" to ") + ; print(repr_pos_r) ) ; print("\n") end - function insn_list_to_tape (insns: vm_insn_list): vm_tape = - let var length := insn_list_length(insns) - var tape := vm_tape_tape [length] of nil - var index := 0 - var head := insns.first - in while index < length - do ( tape[index] := head.insn - ; index := index + 1 - ; head := head.next ) - ; vm_tape { length = length, tape = tape } - end - - in insn_list_to_tape( concat_lists(copy_list(STD_LIB) - , compile_rec(ast, true))) + in compile_rec(ast, true) end function optimize_vm_tape (real_tape: vm_tape): vm_tape = @@ -1216,7 +1423,7 @@ let /* Booleans */ | vm_insn_num_opcodes <= insn.opcode | vm_insn_info[insn.opcode] = nil - then ( print(concatm( "Encountered unknown opcode " + then ( print(concat5( "Encountered unknown opcode " , int_to_string(insn.opcode) , " in insn_to_string!\n" , "", "")) @@ -1225,12 +1432,12 @@ let /* Booleans */ then "NOOP" else let var info := vm_insn_info[insn.opcode] - in concatm( info.mnemonic + in concat5( info.mnemonic , if info.uses_arg1 then concat(" ", int_to_string(insn.arg1)) else "" , if info.uses_arg2 - then concatm(" \"", insn.arg2, "\"", "", "") + then concat5(" \"", insn.arg2, "\"", "", "") else "" , if info.uses_arg3 then concat(" ", value_to_string(insn.arg3)) @@ -1242,7 +1449,7 @@ let /* Booleans */ let var str := "TAPE\n" var index := 0 var real_tape := tape.tape - var length := tape.length + var length := tape.filled var ln_width := size(int_to_string(tape.length)) function repeat (str: string, i: int): string = @@ -1256,7 +1463,7 @@ let /* Booleans */ end in while index < length - do ( str := concatm( str + do ( str := concat5( str , line_number(index) , " " , insn_to_string(real_tape[index]) @@ -1324,45 +1531,41 @@ let /* Booleans */ var GLOBAL_ENV_SENTINEL := "" function env_new(): vm_env = - vm_env { key = GLOBAL_ENV_SENTINEL - , value = bool_val(0) - , next = STD_LIB_ENV } + pair_val( pair_val( sym_val(GLOBAL_ENV_SENTINEL) + , bool_val(0)) + , ENV_STD ) - function env_seek_elem(env: vm_env, key: vm_env_key): vm_env = + function env_seek_elem(env: vm_env, key: string): vm_env = let var head := env - in while head <> nil & head.key <> key - do head := head.next - ; head + in while head <> nil + & head.typ <> type_nil + & head.val_car.val_car.val_s <> key + + do head := head.val_cdr + ; if head <> nil + & head.typ <> type_nil + then head + else nil end - function env_push(env: vm_env, key: vm_env_key, value: vm_env_elem): vm_env = - vm_env { key = key - , value = value - , next = env } + function env_push(env: vm_env, key: string, value: vm_env_elem): vm_env = + pair_val( pair_val( sym_val(key) + , value) + , env ) - function global_env_push (env: vm_env, key: vm_env_key, value: vm_env_elem): vm_env = + function global_env_push (env: vm_env, key: string, value: vm_env_elem): vm_env = let - in if env.key <> GLOBAL_ENV_SENTINEL + in if env.val_car.val_s <> GLOBAL_ENV_SENTINEL then print("Attempting to perform global push to non-global environment") - else env.next := vm_env { key = key - , value = value - , next = env.next } + else env.val_cdr := pair_val( pair_val( sym_val(key) + , value) + , env.val_cdr ) ; env end function env_to_string (env: vm_env): string = - let function iter (list: vm_env): string = - if list = nil then "" - else concat("(", - concat(list.key, - concat(": ", - concat(value_to_string(list.value), if list.next <> nil - then concat("), ", iter(list.next)) - else ")")))) - - in concat("[", concat(iter(env), "]")) - end + value_to_string(env) /* Tape */ @@ -1375,37 +1578,55 @@ let /* Booleans */ , source: string , global_env : vm_env ) = - let var tape_size := tape.length + let var tape_info := tape var tape := tape.tape var continue := true + function expect_type(value: scheme_value, typ: type_type, name: string) = + if value.typ <> typ + then run_error(concat5( name + , " was not " + , if typ = type_integer + then "integer" + else "???" + , ": " + , value_to_string(value))) + function vm_update () = if not(continue) then () else if tape[ip] = nil then run_error("Missing instruction in tape") - else if not (0 <= ip & ip < tape_size) + else if not (0 <= ip & ip < tape_info.filled) then run_error("Instruction pointer out of bounds") /* Integer binary operators */ else if let var op := tape[ip].opcode - in op = OPCODE_ADD | op = OPCODE_MULT | op = OPCODE_GEQ end + in op = OPCODE_ADD + | op = OPCODE_MULT + | op = OPCODE_NUMEQ + | op = OPCODE_GEQ end + then let var opcode := tape[ip].opcode var arg2 := stack_pop(stack) var arg1 := stack_pop(stack) var val: scheme_value := nil - in if not (is_integer(arg1)) then run_error("Argument #1 to binary operation was not integer") - ; if not (is_integer(arg2)) then run_error("Argument #2 to binary operation was not integer") + in expect_type(arg1, type_integer, "Argument #1 to binary operation") + ; expect_type(arg2, type_integer, "Argument #2 to binary operation") + ; val := if opcode = OPCODE_ADD then int_val(arg1.val_i + arg2.val_i) else if opcode = OPCODE_MULT then int_val(arg1.val_i * arg2.val_i) else if opcode = OPCODE_GEQ then bool_val(arg1.val_i >= arg2.val_i) + else if opcode = OPCODE_NUMEQ + then bool_val(arg1.val_i = arg2.val_i) else (run_error("Impossible!"); bool_val(0)) + ; stack_push(stack, val) - ; if ip >= 0 then ip := ip + 1 + ; ip := ip + 1 end else if tape[ip].opcode = OPCODE_PUSH @@ -1451,16 +1672,16 @@ let /* Booleans */ else if not(is_function(call_name_pos.value)) then run_error(concat("Cannot call ", value_to_string(call_name_pos.value))) else ( ip := call_name_pos.value.val_i - ; env := call_name_pos.value.val_e + ; env := call_name_pos.value.val_car ; call_name_pos.value := fun_val(return_ip, return_env) ) end else if tape[ip].opcode = OPCODE_LOAD then let var value_container := env_seek_elem(env, tape[ip].arg2) in if value_container <> nil - then ( stack_push(stack, value_container.value) + then ( stack_push(stack, value_container.val_car.val_cdr) ; ip := ip + 1 ) - else run_error(concatm( "Attempting to access unknown variable \"" + else run_error(concat5( "Attempting to access unknown variable \"" , tape[ip].arg2 , "\"\n Environment looks like " , env_to_string(env) @@ -1492,7 +1713,7 @@ let /* Booleans */ else if not(is_function(return_to)) then run_error(concat("Cannot return to non-function value ", value_to_string(return_to))) else ( ip := return_to.val_i - ; env := return_to.val_e) + ; env := return_to.val_car) end else if tape[ip].opcode = OPCODE_POP @@ -1543,6 +1764,7 @@ let /* Booleans */ ; ip := ip + 1 ) end + else if tape[ip].opcode = OPCODE_SET then let var head := stack_pop(stack) var sym := tape[ip].arg2 @@ -1550,12 +1772,54 @@ let /* Booleans */ in if head = nil then run_error("Stack too shallow!") else if elem = nil - then run_error(concatm( "Attempting to set unknown variable \"" + then run_error(concat5( "Attempting to set unknown variable \"" , sym , "\"\n Environment looks like " , env_to_string(env) , "")) - else ( elem.value := head + else ( elem.val_car.val_cdr := head + ; ip := ip + 1 ) + end + + else if tape[ip].opcode = OPCODE_FRSTR + then let var head := stack_pop(stack) + in if head = nil then run_error("Stack too shallow!") + else if not(is_string(head)) + then run_error(concat("Cannot parse non-string value ", value_to_string(head))) + else ( stack_push(stack, parse_string(head.val_s)) + ; ip := ip + 1 ) + end + + else if tape[ip].opcode = OPCODE_COMPILE + then let var ast := stack_pop(stack) + in if ast = nil + then run_error("Stack too shallow!") + else + let var pos_of_fun := tape_append(tape_info, compile_to_vm(ast)) + in stack_push(stack, fun_val(pos_of_fun, ENV_EMPTY)) + ; ip := ip + 1 + end + end + + else if tape[ip].opcode = OPCODE_SETENV + then let var stack_fun := stack_pop(stack) + var stack_env := stack_pop(stack) + in if stack_fun = nil | stack_env = nil + then run_error("Stack too shallow!") + else if stack_fun.typ <> type_closure + then run_error(concat("Cannot set environment of non-function value ", value_to_string(stack_fun))) + else if stack_env.typ <> type_pair + then run_error(concat("Cannot use non-list value as environment: ", env_to_string(stack_env))) + + else ( stack_push(stack, fun_val( stack_fun.val_i, stack_env )) + ; ip := ip + 1 ) + end + + else if tape[ip].opcode = OPCODE_TYPEOF + then let var value := stack_pop(stack) + in if value = nil + then run_error("Stack too shallow!") + else ( stack_push(stack, int_val(value.typ)) ; ip := ip + 1 ) end @@ -1563,7 +1827,8 @@ let /* Booleans */ , int_to_string(tape[ip].opcode))) function run_error(errmsg: string) = - let + let var repr_pos_l := pos_to_string(tape[ip].pos_l) + var repr_pos_r := pos_to_string(tape[ip].pos_r) in print("Tiger-scheme runtime error\n ") ; print(errmsg) ; print("\n At instruction ") @@ -1571,7 +1836,14 @@ let /* Booleans */ ; print(": ") ; print(insn_to_string(tape[ip])) ; print("\n Scheme: ") - ; print(safe_substring(source, tape[ip].pos_l, tape[ip].pos_r)) + ; print(safe_substring( source + , at_char(tape[ip].pos_l) + , at_char(tape[ip].pos_r) )) + ; print("\n Source: ") + ; print(repr_pos_l) + ; if repr_pos_l <> repr_pos_r + then ( print(" to ") + ; print(repr_pos_r) ) ; print("\n") ; continue := false end @@ -1609,12 +1881,17 @@ let /* Booleans */ ; print("\n") ; print("** Compilation **\n") ; 1) - var tape := compile_to_vm(sexp_ast) - var tape := optimize_vm_tape(tape) + var tape := tape_new(1000) + var ignore := ( tape_append(tape, STD_LIB) + ; tape_append(tape, compile_to_vm(sexp_ast)) + ; "Ignore!" ) + + /*var tape := optimize_vm_tape(tape) var ignore := ( print("Compiled!:\n") ; print(tape_to_string(tape)) ; print("\n") - ; 1) + ; 1) */ + var stack := stack_new() var env := env_new()