/* # Tiger Scheme Almost complete implementation of Scheme in Tiger. Performs translation to bytecode, where after it executes the bytecode. As far as I remember, it doesn't support closures, and only some of the macro forms. - First change: Jan 5 2019 - Latest change: Dec 5 2019 */ let /* Booleans */ type bool = int var true := 1 var false := 0 /* Settings */ var IS_NIL_TRUTHY : bool := false var HAS_NIL_SYMBOL : bool := false var ALLOW_TAPE_RESIZE : bool := true var ASSUME_NO_OVERWRITE_STDLIB : bool := true var DEBUG_PRINT_STACK : bool := false var DEBUG_PRINT_TAPE : bool := false var DEBUG_PRINT_PARSED : bool := false var DEBUG_PRINT_JUMPS : bool := false var DEBUG_PRINT_MACRO : bool := true var DEBUG_SHOW_FULL_ENVIRONMENT : bool := false var TRIGGERED_EXIT : bool := false /* Basic utility */ function concat5 ( s1: string , s2: string , s3: string , s4: string , s5: string ): string = concat(s1, concat(s2, concat(s3, concat(s4, s5)))) function concat6 ( s1: string , s2: string , s3: string , s4: string , s5: string , s6: string ): string = concat(concat5(s1, s2, s3, s4, s5), s6) 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 do value := value * 10 + (ord(substring(str, i, 1))-ord("0")) ; value end function string_to_int (str: string): int = if size(str) > 1 & substring(str, 0, 1) = "-" then - string_to_unsigned_int(substring(str, 1, size(str)-1)) else string_to_unsigned_int(str) function i2s (i: int): string = if i = 0 /* TAKEN FROM FREKSEN LISP. TODO REPLACE */ then "0" else if i < 0 then concat("-", i2s(-i)) else if i < 10 then chr(ord("0") + i) else concat(i2s(i / 10), chr(ord("0") + i - (i / 10) * 10)) function int_to_string (i: int): string = i2s(i) function is_integer_string (s: string): int = s = int_to_string(string_to_int(s)) function max (a: int, b: int): int = if a > b then a else b function min (a: int, b: int): int = if a < b then a else b function safe_substring (str: string, i_start: int, i_end: int): string = ( i_start := max(0, i_start) ; i_end := min(size(str) - 1, i_end) ; if i_start > i_end then "" else substring(str, i_start, i_end - i_start + 1) ) /* Map */ type map_link = { key : string, value : string, next: map_link } type map = { first : map_link } function map_add (map: map, key: string, value: string) = map.first := map_link { key = key, value = value, next = map.first } function map_find (map: map, key: string, default: string): string = let function link_find (link: map_link): string = if link = nil then default else if link.key = key then link.value else link_find(link.next) in link_find(map.first) end var SYMBOL_TO_SHORT_REPR := let var M := map { first = nil } in map_add(M, "quote", "'") ; map_add(M, "quasiquote", "`") ; map_add(M, "unquote", ",") ; map_add(M, "unquote-splicing", ",@") ; M end /* 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 = if pos <> nil then pos.line_num else -3 function at_char (pos: pos): int = if pos <> nil then pos.at_char else -3 function pos_delta_char (pos: pos, delta: int): pos = new_pos( line_num(pos) , at_char (pos) + delta) var pos_unknown : pos := new_pos(-1, -1) var pos_preamble: pos := new_pos(-2, -2) var pos_bad : pos := new_pos(-3, -3) function pos_to_string (pos: pos): string = if pos <> nil then "no position" else if pos = pos_unknown then "unknown position" else if pos = pos_preamble then "preamble" else concat("line ", int_to_string(line_num(pos))) /* Scheme value system */ type type_type = int type scheme_value = { typ : type_type , val_i : int , val_s : string , val_car : scheme_value , val_cdr : scheme_value , pos_l: pos , pos_r: pos } type vm_env_key = scheme_value type vm_env_elem = scheme_value type vm_env = scheme_value type scheme_environment = vm_env var type_any := 0 var type_integer := 8 var type_string := 1 var type_symbol := 2 var type_closure := 3 var type_nil := 4 var type_false := 5 var type_true := 6 var type_pair := 7 var type_info := let var type_capacity := 10 type type_info = array of string var type_info := type_info[type_capacity] of "" function new_type (type_id: int, type_name: string) = type_info[type_id] := type_name in new_type(type_any, "*") ; new_type(type_integer, "integer") ; new_type(type_string, "string") ; new_type(type_symbol, "symbol") ; new_type(type_closure, "function") ; new_type(type_nil, "'()") ; new_type(type_false, "#f") ; new_type(type_true, "#t") ; new_type(type_pair, "pair") ; type_info end function type_id_to_name(id: int): string = type_info[id] 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) else if v.typ = type_string then concat("\"", concat(v.val_s, "\"")) else if v.typ = type_symbol then v.val_s else if v.typ = type_closure then concat("")) else if v.typ = type_nil then "()" else if v.typ = type_false then "#f" else if v.typ = type_true then "#t" else if v.typ = type_pair & v.val_cdr = nil then error_value_to_string(v) else if v.typ = type_pair & v.val_car.typ = type_symbol & map_find(SYMBOL_TO_SHORT_REPR, v.val_car.val_s, "") <> "" & v.val_cdr.typ = type_pair & v.val_cdr.val_cdr.typ = type_nil then concat(map_find(SYMBOL_TO_SHORT_REPR, v.val_car.val_s, "") , value_to_string(v.val_cdr.val_car)) else if v.typ = type_pair & v.val_cdr <> nil & v.val_cdr.typ = type_nil then let in concat5 ( if req_paren then "(" else "" , val_rec(v.val_car, true) , if req_paren then ")" else "" , "" , "" ) end else if v.typ = type_pair 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)) , if req_paren then ")" else "" ) end else ( print("Error in value_to_string: Unknown type.\n") ; error_value_to_string(v) ) in val_rec(base_v, true) end function is_truthy (e: scheme_value): bool = e <> nil & e.typ <> type_false & (IS_NIL_TRUTHY | e.typ <> type_nil) function is_integer (e: scheme_value): bool = e <> nil & e.typ = type_integer function is_string (e: scheme_value): bool = e <> nil &e.typ = type_string function is_function (e: scheme_value): bool = e <> nil &e.typ = type_closure function is_pair (e: scheme_value): bool = e <> nil &e.typ = type_pair function is_symbol (e: scheme_value): bool = e <> nil &e.typ = type_symbol function is_boolean (e: scheme_value): bool = e <> nil & (e.typ = type_true | e.typ = type_false) function int_val (i: int): scheme_value = scheme_value { typ = type_integer , val_i = i , val_s = "" , val_car = nil , val_cdr = nil , 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_car = nil , val_cdr = nil , pos_l = pos_unknown , pos_r = pos_unknown } function restrictive_fun_val (i: int, env: scheme_environment, name: string, num_args: int, vararg: bool): scheme_value = /* TODO: Implement system for tracking expected number of arguments to function */ scheme_value { typ = type_closure , val_i = i , val_s = name , val_car = env , val_cdr = nil , pos_l = pos_unknown , pos_r = pos_unknown } function named_fun_val (i: int, env: scheme_environment, name: string): scheme_value = restrictive_fun_val(i, env, name, -1, false) function fun_val (i: int, env: scheme_environment): scheme_value = named_fun_val(i, env, "") var VAL_TRUE := scheme_value { typ = type_true , val_i = 1 , val_s = "" , val_car = nil , val_cdr = nil , 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_car = car , val_cdr = cdr , pos_l = pos_unknown , pos_r = pos_unknown } function string_val (str: string): scheme_value = scheme_value { typ = type_string , val_i = 0 , val_s = str , val_car = nil , val_cdr = nil , 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_car = nil , val_cdr = nil , pos_l = pos_unknown , pos_r = pos_unknown } function nil_val (): scheme_value = scheme_value { typ = type_nil , val_i = 0 , val_s = "" , val_car = nil , val_cdr = nil , pos_l = pos_unknown , pos_r = pos_unknown } function scheme_number_equal (a: scheme_value, b: scheme_value): bool = a.typ = type_integer & b.typ = type_integer & a.val_i = b.val_i function scheme_value_is_proper_list (ls: scheme_value): bool = if ls = nil then false else ls.typ = type_nil | ls.typ = type_pair & scheme_value_is_proper_list(ls.val_cdr) /* evq? See for definition: * https://people.csail.mit.edu/jaffer/r5rs/Equivalence-predicates.html * */ function scheme_value_evq (a: scheme_value, b: scheme_value): bool = /* The eqv? procedure defines a useful equivalence relation on * objects. Briefly, it returns #t if obj1 and obj2 should * normally be regarded as the same object. */ let in if false then false /* Different types: - #f iff a and b are of different types - #f iff one of a and b is the empty list but the other is not. - #f iff one of a and b is #t but the other is #f */ else if a.typ <> b.typ then false /* Booleans - #t iff a and b are both #t or both #f */ else if is_boolean(a) then a.val_i = b.val_i /* Integers - #t iff a and b are both numbers, (= a b), and are either both exact or both inexact. - #f iff one of a and b is an exact number but the other is an inexact number. - #f iff both a and b are numbers for which the = procedure returns #f */ else if a.typ = type_integer then scheme_number_equal(a, b) /* TODO: Characters - Delegated to (char=? a b) */ else if false then false /* Empty lists - #t iff both a and b are the empty list */ else if a.typ = type_nil then true /* Symbols: - Delegate to (string=? (symbol->string a) (symbol->string b)) */ else if a.typ = type_symbol then a.val_s = b.val_s /* TODO: symbol->string */ /* Pairs, vectors, strings: - #t iff a and b are pairs, vectors, or strings that denote the same locations in the store - #f iff a and b are pairs, vectors, or strings that denote distinct locations. */ else if a.typ = type_pair | a.typ = type_string /* TODO: Vector */ then a = b /* Procedures: - a and b are procedures whose location tags are equal. - a and b are procedures that would behave differently. */ else if a.typ = type_closure then a = b else ( print("Undefined eqv application") ; true ) end var VALUE_UNSPECIFIED := nil_val() /* Parsing */ type sexp_ast = scheme_value function parse_string (str: string): sexp_ast = 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_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): bool = let var ascii := ord(substring(str, index, 1)) 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 = sexp_ast { typ = type_nil , val_i = 0 , val_s = "" , val_car = nil , val_cdr = nil , pos_l = pos_l , pos_r = pos_r } 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" then bool_val(1) else if is_integer_string(sym) then int_val(string_to_int(sym)) else sym_val(sym) in val.pos_l := pos_l ; val.pos_r := pos_r ; val end 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 , pos_r: pos): sexp_ast = sexp_ast { typ = type_pair , val_i = 0 , val_s = "" , 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 */ 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) then ( while ord(substring(str, index, 1)) <> ord("\n") do index := index + 1 ; ignore_ws()) function parse_rec (): sexp_ast = ( ignore_ws() ; if index >= size(str) then (parse_error("Reached end of string"); nil) else if is_symbol(index) then let var start_pos := new_pos(line_number, 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_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") ; "PARSING_ERROR") var datum := ( index := index + 1 ; if modifier = "unquote-splicing" then index := index + 1 ; parse_rec() ) var exp := sexp_wrap( modifier , 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 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(pos, pos) , parsed.pos_l , parsed.pos_r ) /* Initial link */ in if sexp = nil then ( sexp_last := link ; sexp := sexp_last ) /* In case of . syntax. For * example: (a . b) */ /* TODO: Below is ugly! */ else if parsed.typ = type_symbol & parsed.val_s = "." then ( index := index + 1 ; sexp_last.val_cdr := parse_rec() ; link.pos_r := sexp_last.val_cdr.pos_r ) /* Continue along with sexp * parsing */ else ( sexp_last.val_cdr := link ; sexp_last := sexp_last.val_cdr ) ; 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") /* Give correct positions */ ; sexp_last := sexp ; while sexp_last <> nil do ( sexp_last.pos_r := most_right ; sexp_last := sexp_last.val_cdr ) ; if sexp <> nil 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( start_pos , most_right ) else sexp end else (parse_error("Found no way to progress parsing"); nil)) function parse_error(errmsg: string) = let in print("Tiger-scheme parse error\n ") ; print(errmsg) ; print("\n At index: ") ; print(int_to_string(index)) ; print("\n Nearby: ") ; print(safe_substring(str, index-10, index+10)) ; print("\n") end in if size(str) > 0 then parse_rec() else (parse_error("Nothing to parse. Given string empty!"); nil) end /**** Instructions ****/ type vm_insn = { opcode: int , arg1: int , arg2: string , arg3: scheme_value , pos_l: pos , pos_r: pos } type vm_tape_tape = array of vm_insn type vm_tape = { capacity: int , filled: int , tape: vm_tape_tape } type vm_insn_info = { opcode : int , mnemonic : string , uses_arg1 : int , uses_arg2 : int , uses_arg3 : int } type vm_insn_info_l = array of vm_insn_info var OPCODE_ADD := 0 var OPCODE_PUSH := 1 var OPCODE_GOTO := 2 var OPCODE_CSKIP := 3 var OPCODE_DUPL := 4 var OPCODE_SWITCH := 5 var OPCODE_MULT := 6 var OPCODE_LOAD := 7 var OPCODE_CALL := 9 var OPCODE_RET := 10 var OPCODE_DGOTO := 11 var OPCODE_DEF := 12 var OPCODE_SETG := 8 var OPCODE_DEFFUN := 13 var OPCODE_POP := 14 var OPCODE_GEQ := 15 var OPCODE_OUTPUT := 17 var OPCODE_TOSTR := 18 var OPCODE_CONS := 19 var OPCODE_CAR := 20 var OPCODE_CDR := 16 var OPCODE_SET := 21 var OPCODE_FRSTR := 22 var OPCODE_COMPILE:= 23 var OPCODE_SETENV := 24 var OPCODE_GETENV := 30 var OPCODE_NUMEQ := 25 var OPCODE_TYPEOF := 26 var OPCODE_EXIT := 27 var OPCODE_EQV := 28 var OPCODE_CONCAT := 29 var OPCODE_FORGET := 32 var OPCODE_DEBUG := 31 var vm_insn_num_opcodes := 0 var vm_insn_info := let var expected_number_opcodes := 40 var a := vm_insn_info_l [expected_number_opcodes] of nil function code ( opcode : int , mnemonic : string , uses_arg1 : int , uses_arg2 : int , uses_arg3 : int ) = ( if a[opcode] <> nil then ( print(concat5( "Error: Overwriting previously defined opcode information!\n Opcode: " , int_to_string(opcode) , " with previous mnenomic " , a[opcode].mnemonic , "\n")) ; TRIGGERED_EXIT := true ) ; a[opcode] := vm_insn_info { opcode = opcode , mnemonic = mnemonic , uses_arg1 = uses_arg1 , uses_arg2 = uses_arg2 , uses_arg3 = uses_arg3 } ; vm_insn_num_opcodes := vm_insn_num_opcodes + 1 ) in code(OPCODE_ADD, "ADD", 0, 0, 0) ; code(OPCODE_PUSH, "PUSH", 0, 0, 1) ; code(OPCODE_GOTO, "GOTO", 1, 0, 0) ; code(OPCODE_DGOTO, "DGOTO", 1, 0, 0) ; code(OPCODE_CSKIP, "CSKIP", 1, 0, 0) ; code(OPCODE_DUPL, "DUPL", 1, 0, 0) ; code(OPCODE_SWITCH, "SWITCH", 0, 0, 0) ; code(OPCODE_MULT, "MULT", 0, 0, 0) ; code(OPCODE_LOAD, "LOAD", 2, 1, 0) ; code(OPCODE_CALL, "CALL", 1, 0, 0) ; code(OPCODE_RET, "RET", 1, 0, 0) ; code(OPCODE_DEF, "DEF", 0, 1, 0) ; code(OPCODE_FORGET, "FORGET", 1, 0, 0) ; 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) ; 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) ; code(OPCODE_SETENV, "SETENV", 0, 0, 0) ; code(OPCODE_GETENV, "GETENV", 0, 0, 0) ; code(OPCODE_EXIT, "EXIT", 1, 0, 0) ; code(OPCODE_EQV, "EQV", 0, 0, 0) ; code(OPCODE_CONCAT, "CONCAT", 0, 0, 0) ; code(OPCODE_DEBUG, "DEBUG", 1, 0, 0) ; for i := 1 to expected_number_opcodes - 1 do if a[i] <> nil & a[i-1] = nil then print(concat5("Error: Opcode info array incorrectly initialized!\n Opcode " , int_to_string(i) , " is declared, but " , int_to_string(i-1) , " is not!")) ; print("Virtual Machine possess ") ; print(int_to_string(vm_insn_num_opcodes)) ; print(" instructions. Has space for ") ; print(int_to_string(expected_number_opcodes)) ; print(".\n") ; a end function noop_insn (pos_l: pos, pos_r: pos): vm_insn = vm_insn { opcode = OPCODE_DGOTO , arg1 = 1 , arg2 = "" , arg3 = nil , pos_l = pos_l , pos_r = pos_r } /**** Compile to VM ****/ 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 { 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 if DEBUG_PRINT_TAPE then ( print("Resizing tape with ratio ") ; print(int_to_string(tape.filled)) ; print("/") ; print(int_to_string(tape.capacity)) ; print(" to new capacity of ") ; print(int_to_string(new_size)) ; print("\n") ) ; for i := 0 to tape.filled - 1 do new_tape_tape[i] := tape.tape[i] ; tape.tape := new_tape_tape ; tape.capacity := new_size end 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 new_insns := insn_list_length(new_insns) /* TODO: Ensure enough space on tape for new additions. */ /* 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 & head.insn <> nil do ( tape.tape[index] := head.insn ; index := index + 1 ; head := head.next ) ; tape.filled := index /* Report if debug enabled */ ; if DEBUG_PRINT_TAPE then ( print("Appended ") ; print(int_to_string(new_insns)) ; print(" new instructions to tape,\n\tIn range: ") ; print(int_to_string(index_start)) ; print(" to ") ; print(int_to_string(index-1)) ; print("\n\tTape ratio: ") ; print(int_to_string(tape.filled)) ; print("/") ; print(int_to_string(tape.capacity)) ; print("\n") ) /* Return start of new appendings */ ; 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(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 " , "nil\n")) else if a.first = nil then ( a.first := b.first ; a.last := b.last ) else ( a.last.next := b.first ; a.last := b.last ) ; a ) function single_insn (insn: vm_insn): vm_insn_list = let var link := vm_insn_list_link { insn = insn, next = nil } in vm_insn_list { first = link, last = link } end 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 , arg3 = nil , pos_l = pos_l , pos_r = pos_r })) ; ()) 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 = "" , arg3 = arg3 , pos_l = pos_l , pos_r = pos_r })) ; ()) 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): vm_insn_list = if insn = nil then nil else let var insns := single_insn(insn) in tail_position(insns, return_now, insn.pos_l, insn.pos_r) ; insns end 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 std_insns := vm_insn_list { first = nil, last = nil } function app (opcode: int, arg1: int, arg2: string) = app_insn(std_insns, opcode, arg1, arg2, pos_preamble, pos_preamble) function app2 (opcode: int, arg3: scheme_value) = app_insn2(std_insns, opcode, arg3, pos_preamble, pos_preamble) function stdval (name: string, value: scheme_value) = ENV_STD := pair_val( pair_val( sym_val(name), value) , ENV_STD ) function tape_pos (): int = insn_list_length(std_insns) function stdfun (name: string) = stdval(name, named_fun_val(tape_pos(), nil, name)) function stdfun2 (name: string, num_args: int, vararg: bool) = stdval(name, restrictive_fun_val(tape_pos(), nil, name, num_args, vararg)) in () /* Nil */ ; if HAS_NIL_SYMBOL then stdval("nil", nil_val()) /* Identity function */ ; stdfun("syntax->datum") ; stdfun("datum->syntax") ; STD_LIB_ID_FUNCTION := fun_val(tape_pos(), nil) ; app(OPCODE_RET, 1, "") /* R5RS: Equivalence */ ; stdfun2("eqv?", 2, false) ; app(OPCODE_EQV, 0, "") ; app(OPCODE_RET, 1, "") /* R5RS: Boolean */ ; stdfun("not") ; app2(OPCODE_PUSH, bool_val(false)) ; app(OPCODE_EQV, 0, "") ; app(OPCODE_RET, 1, "") ; stdfun("boolean?") /* Test for false */ ; app(OPCODE_DUPL, 0, "") ; app2(OPCODE_PUSH, bool_val(false)) ; app(OPCODE_EQV, 0, "") ; app(OPCODE_CSKIP, 4, "") /* Is true, remove top and return */ ; app(OPCODE_POP, 0, "") ; app2(OPCODE_PUSH, bool_val(1)) ; app(OPCODE_RET, 1, "") /* Not false, maybe true? */ ; app2(OPCODE_PUSH, bool_val(true)) ; app(OPCODE_EQV, 0, "") ; app(OPCODE_RET, 1, "") /* R5RS: Pairs and Lists */ ; 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, "") ; app(OPCODE_RET, 1, "") ; stdfun("caaaar") ; app(OPCODE_CAR, 0, "") ; stdfun("caaar") ; app(OPCODE_CAR, 0, "") ; stdfun("caar") ; app(OPCODE_CAR, 0, "") ; stdfun("car") ; app(OPCODE_CAR, 0, "") ; app(OPCODE_RET, 1, "") ; stdfun("cadddr") ; app(OPCODE_CDR, 0, "") ; stdfun("caddr") ; app(OPCODE_CDR, 0, "") ; stdfun("cadr") ; app(OPCODE_CDR, 0, "") ; app(OPCODE_CAR, 0, "") ; app(OPCODE_RET, 1, "") ; stdfun("caadar") ; app(OPCODE_CAR, 0, "") ; app(OPCODE_DGOTO, 2, "") ; stdfun("caaddr") ; app(OPCODE_CDR, 0, "") ; stdfun("caadr") ; app(OPCODE_CDR, 0, "") ; app(OPCODE_CAR, 0, "") ; app(OPCODE_CAR, 0, "") ; app(OPCODE_RET, 1, "") ; stdfun("cadadr") ; app(OPCODE_CDR, 0, "") ; app(OPCODE_DGOTO, 2, "") ; stdfun("cadaar") ; app(OPCODE_CAR, 0, "") ; stdfun("cadar") ; app(OPCODE_CAR, 0, "") ; app(OPCODE_CDR, 0, "") ; app(OPCODE_CAR, 0, "") ; app(OPCODE_RET, 1, "") ; stdfun("cddddr") ; app(OPCODE_CDR, 0, "") ; stdfun("cdddr") ; app(OPCODE_CDR, 0, "") ; stdfun("cddr") ; app(OPCODE_CDR, 0, "") ; stdfun("cdr") ; 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: String */ ; stdfun("string?") ; app(OPCODE_TYPEOF, 0, "") ; app2(OPCODE_PUSH, int_val(type_string)) ; app(OPCODE_NUMEQ, 0, "") ; app(OPCODE_RET, 1, "") ; stdfun("string-append") ; app(OPCODE_SWITCH, 0, "") ; app(OPCODE_CONCAT, 0, "") ; app(OPCODE_SWITCH, 0, "") ; app(OPCODE_CONCAT, 0, "") ; app(OPCODE_RET, 1, "") /* 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, 2, "") ; 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("datum->string") ; app(OPCODE_TOSTR, 0, "") ; app(OPCODE_RET, 1, "") ; stdfun("set-env!") ; app(OPCODE_SWITCH, 0, "") ; app(OPCODE_SETENV, 0, "") ; app(OPCODE_RET, 1, "") ; stdfun("get-env") ; app(OPCODE_GETENV, 0, "") ; app(OPCODE_RET, 1, "") ; stdfun("debug-show-tape") ; app(OPCODE_DEBUG, 1, "") ; app2(OPCODE_PUSH, VALUE_UNSPECIFIED) ; app(OPCODE_RET, 1, "") ; stdfun("debug-show-stack") ; app(OPCODE_DEBUG, 2, "") ; app2(OPCODE_PUSH, VALUE_UNSPECIFIED) ; app(OPCODE_RET, 1, "") ; stdfun("debug-show-env") ; app(OPCODE_DEBUG, 3, "") ; app2(OPCODE_PUSH, VALUE_UNSPECIFIED) ; app(OPCODE_RET, 1, "") ; stdfun("exit") ; app(OPCODE_EXIT, true, "") /* Should never be called as function! */ ; stdfun("quote") ; stdfun("quasiquote") ; stdfun("unquote") ; stdfun("unquote-splicing") ; app2(OPCODE_PUSH, string_val("Error! This is a macro and cannot be called as an actual function!\n")) ; app(OPCODE_OUTPUT, 0, "") ; app(OPCODE_EXIT, true, "") /* Misc??? */ ; stdfun("symbol?") ; app(OPCODE_TYPEOF, 0, "") ; app2(OPCODE_PUSH, int_val(type_symbol)) ; app(OPCODE_NUMEQ, 0, "") ; app(OPCODE_RET, 1, "") ; stdfun("procedure?") ; app(OPCODE_TYPEOF, 0, "") ; app2(OPCODE_PUSH, int_val(type_closure)) ; app(OPCODE_NUMEQ, 0, "") ; app(OPCODE_RET, 1, "") ; std_insns end /**** Virtual Machine ****/ /* Stack */ type vm_stack_elem = scheme_value type vm_stack_list = { value: vm_stack_elem, below: vm_stack_list } type vm_stack = { list: vm_stack_list } function stack_new(): vm_stack = vm_stack { list = nil } function stack_peak(stack: vm_stack): vm_stack_elem = if stack = nil then (print("Error in stack_peak: Not given stack!\n"); nil) else if stack.list = nil then nil else stack.list.value function stack_pop(stack: vm_stack): vm_stack_elem = if stack = nil then (print("Error in stack_pop: Not given stack!\n"); nil) else if stack.list = nil then nil else let var head := stack.list.value in stack.list := stack.list.below ; head end function stack_seek_elem(stack: vm_stack, index: int): vm_stack_list = let var head := stack.list in for index := 1 to index do if head <> nil then head := head.below ; head end function stack_destroy_elem(stack: vm_stack, index: int): vm_stack_elem = if index <= 0 then let var value := stack.list.value in stack.list := stack.list.below ; value end else let var before := stack_seek_elem(stack, index - 1) in if before = nil | before.below = nil then nil else let var value := before.below.value in before.below := before.below.below ; value end end function stack_push(stack: vm_stack, elem: vm_stack_elem) = stack.list := vm_stack_list { value = elem , below = stack.list } function stack_to_string (stack: vm_stack): string = let function iter (list: vm_stack_list): string = if list = nil then "" else concat(value_to_string(list.value), if list.below <> nil then concat(", ", iter(list.below)) else "") in concat("[", concat(iter(stack.list), "]")) end /* Environments */ var GLOBAL_ENV_SENTINEL := "" function env_new(base_env: scheme_value): vm_env = pair_val( pair_val( sym_val(GLOBAL_ENV_SENTINEL) , bool_val(0)) , base_env ) function env_seek_elem(env: vm_env, key: string): vm_env = let function valid_head (head: vm_env): bool = head <> nil & head.typ <> type_nil /*& 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 valid_head(head) & head.val_car.val_car.val_s = key then head else nil end function env_push(env: vm_env, key: string, value: vm_env_elem): vm_env = pair_val( pair_val( sym_val(key) , value) , env ) function env_pop(env: vm_env): vm_env = env.val_cdr function global_env_push (env: vm_env, key: string, value: vm_env_elem): vm_env = let in if env.val_car.val_s <> GLOBAL_ENV_SENTINEL then print("Attempting to perform global push to non-global environment") 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 = value_to_string(env) function is_reserved (symbol: string): bool = symbol = "let" | symbol = "let*" | symbol = "letrec" | symbol = "lambda" | symbol = "do" | symbol = "quote" | symbol = "quasiquote" | symbol = "unquote" | symbol = "unquote-splicing" | symbol = "define" | symbol = "define-syntax" function is_not_variable (symbol: string): bool = symbol = "if" | symbol = "let" | symbol = "unquote" | symbol = "lambda" | symbol = "quote" | symbol = "quasiquote" | symbol = "unquote" | symbol = "unquote-splicing" | symbol = "" /**** Compilation ****/ function compile_to_vm ( ast: sexp_ast , env_macro: scheme_environment , macro_tape: vm_tape , env_global: scheme_environment): 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 do tail := tail.next ; vm_insn_list { first = head, last = tail } end function copy_list (ls: vm_insn_list): vm_insn_list = list(ls.first) function atom_to_insn ( sym: scheme_value , pos_l: pos , pos_r: pos , expected_type: type_type ): vm_insn = if sym = nil then ( print("Error in atom_to_list: Got nil as sym!\n") ; nil ) else if expected_type <> 0 & sym.typ <> type_symbol & sym.typ <> expected_type then ( compile_error( concat5("Error in atom_to_list: Expected " , type_id_to_name(expected_type) , " but got " , value_to_string(sym) , "!\n") , sym) ; nil ) else if is_symbol(sym) & is_not_variable(sym.val_s) then ( compile_error(concat5( "Error in atom_to_list: Impossible to load variable " , sym.val_s , " because it is not a variable!\n" , "" , "") , sym) ; nil ) else if is_symbol(sym) then vm_insn { opcode = OPCODE_LOAD , arg1 = expected_type , arg2 = sym.val_s , arg3 = nil , pos_l = pos_l , pos_r = pos_r } else vm_insn { opcode = OPCODE_PUSH , arg1 = 0 , arg2 = "" , arg3 = sym , pos_l = pos_l , pos_r = pos_r } function sexp_ast_length(insns: vm_insn_list): int = let function rec (insns: vm_insn_list_link, sum: int): int = if insns = nil then sum else rec(insns.next, 1 + sum) in if insns = nil then 0 else rec(insns.first, 0) end function set_tree_positions ( ast: sexp_ast , pos_l: pos , pos_r: pos ) = /* Useful for setting the positions of generated AST. */ if ast <> nil then ( ast.pos_l := pos_l ; ast.pos_r := pos_r ; if ast.typ = type_pair then ( set_tree_positions( ast.val_cdr, pos_l, pos_r) ; set_tree_positions( ast.val_car, pos_l, pos_r) )) function sexp_is_list_of_type ( ast: sexp_ast , subtype: type_type ): bool = if ast = nil then false else if ast.typ = type_nil then true else ast.typ = type_pair & ast.val_car <> nil & ast.val_car.typ = subtype & sexp_is_list_of_type(ast.val_cdr, subtype) function sexp_is_literals_list ( ast: sexp_ast ): bool = sexp_is_list_of_type(ast, type_symbol) function sexp_is_ellipsis ( ast: sexp_ast ): bool = ast <> nil & ast.typ = type_symbol & ast.val_s = "..." function sexp_list_length (ast: sexp_ast): bool = if ast = nil | not(ast.typ = type_pair | ast.typ = type_nil) then false else if ast.typ = type_nil then 0 else let var len := sexp_list_length(ast.val_cdr) in if len < 0 then len else len + 1 end function sexp_is_pattern_datum (ast: sexp_ast): bool = ast <> nil & ( ast.typ = type_integer | ast.typ = type_string | ast.typ = type_true | ast.typ = type_false /* TODO: character */) function sexp_is_pattern_id (ast: sexp_ast): bool = ast <> nil & ast.typ = type_symbol & not(sexp_is_ellipsis(ast)) function sexp_is_pattern ( ast: sexp_ast ): bool = if ast = nil then false /* Pattern Datum */ else if sexp_is_pattern_datum(ast) then true /* The empty list '() is a pattern */ else if ast.typ = type_nil then true /* Ensure it is a pair */ else if ast.typ <> type_pair | ast.val_car = nil | ast.val_cdr = nil then false /* List of patterns: ( ...) */ /* Non-proper list of patterns: ( ... . ) */ else if ast.typ = type_pair & sexp_is_pattern(ast.val_car) & sexp_is_pattern(ast.val_cdr) then true /* ( ... ) */ else if ast.typ = type_pair & sexp_is_pattern (ast.val_car) & sexp_is_ellipsis(ast.val_cdr.val_car) & ast.val_cdr.val_cdr.typ = type_nil then true /* TODO: Hashtag notation (https://people.csail.mit.edu/jaffer/r5rs/Pattern-language.html) */ else false function sexp_is_template ( ast: sexp_ast ): bool = if ast = nil then false /* Pattern Datum */ else if sexp_is_pattern_datum(ast) then true /* The empty list '() is a template */ else if ast.typ = type_nil then true /* Ensure it is a pair */ else if ast.typ <> type_pair | ast.val_car = nil | ast.val_cdr = nil then false /* List of templates: ( ...) */ /* Pair of templates: ( .