2162 lines
86 KiB
Plaintext
2162 lines
86 KiB
Plaintext
|
|
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 DEBUG_PRINT_STACK : bool := false
|
|
var DEBUG_PRINT_TAPE : bool := false
|
|
var DEBUG_PRINT_PARSED : 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 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 = pos.line_num
|
|
function at_char (pos: pos): int =
|
|
if pos <> nil
|
|
then pos.at_char
|
|
else -1
|
|
|
|
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)
|
|
|
|
function pos_to_string (pos: pos): string =
|
|
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_integer := 0
|
|
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
|
|
|
|
function error_value_to_string(v: scheme_value): string =
|
|
if v = nil
|
|
then "<TIGER NIL>"
|
|
else
|
|
let
|
|
in concat8( "<ERROR VALUE: TYPE "
|
|
, int_to_string(v.typ)
|
|
, if v.val_i <> 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("<fun at ", concat(int_to_string(v.val_i), ">"))
|
|
|
|
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 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 fun_val (i: int, env: scheme_environment): scheme_value =
|
|
scheme_value { typ = type_closure
|
|
, val_i = i
|
|
, val_s = ""
|
|
, val_car = env
|
|
, val_cdr = nil
|
|
|
|
, pos_l = pos_unknown
|
|
, pos_r = pos_unknown }
|
|
|
|
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 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 }
|
|
|
|
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 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")
|
|
; "SOMETHING FUCKED UP")
|
|
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 parse_rec()
|
|
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 = { length: 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_NUMEQ := 25
|
|
var OPCODE_TYPEOF := 26
|
|
var OPCODE_EXIT := 27
|
|
|
|
var vm_insn_num_opcodes := 0
|
|
var vm_insn_info :=
|
|
let var expected_number_opcodes := 30
|
|
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"))
|
|
; 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", 0, 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", 0, 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_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_EXIT, "EXIT", 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 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
|
|
; if DEBUG_PRINT_TAPE
|
|
then ( print("Appended new to tape: ")
|
|
; print(int_to_string(index_start))
|
|
; print(" to ")
|
|
; print(int_to_string(index))
|
|
; print("\n") )
|
|
; 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 =
|
|
let var insns := single_insn(insn)
|
|
in tail_position(insns, return_now, insn.pos_l, insn.pos_r)
|
|
; insns
|
|
end
|
|
|
|
function insn_list_length (insns: vm_insn_list): int =
|
|
let var len := 0
|
|
var head := insns.first
|
|
in while head <> nil
|
|
do ( len := len + 1
|
|
; head := head.next )
|
|
; len
|
|
end
|
|
|
|
|
|
var ENV_EMPTY : vm_env := nil_val()
|
|
var ENV_STD : vm_env := ENV_EMPTY
|
|
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, fun_val(tape_pos(), nil))
|
|
|
|
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: 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("car")
|
|
; app(OPCODE_CAR, 0, "")
|
|
; app(OPCODE_RET, 1, "")
|
|
|
|
; 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: 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, "")
|
|
|
|
; stdfun("exit")
|
|
; app(OPCODE_EXIT, true, "")
|
|
|
|
; 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 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"
|
|
|
|
/**** 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): vm_insn =
|
|
if sym = nil
|
|
then ( print("Error in atom_to_list: Got nil as sym!\n")
|
|
; nil )
|
|
else if is_symbol(sym)
|
|
then vm_insn { opcode = OPCODE_LOAD
|
|
, arg1 = 0
|
|
, 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 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: (<pattern> ...) */
|
|
/* Non-proper list of patterns: (<pattern> ... . <pattern>) */
|
|
else if ast.typ = type_pair
|
|
& sexp_is_pattern(ast.val_car)
|
|
& sexp_is_pattern(ast.val_cdr)
|
|
then true
|
|
|
|
/* (<pattern> ... <pattern> <ellipsis>) */
|
|
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: (<template_element> ...) */
|
|
/* Pair of templates: (<template_element> . <template>) */
|
|
/* Where <template_element> is <template> */
|
|
else if ast.typ = type_pair
|
|
& sexp_is_template(ast.val_car)
|
|
& ast.val_cdr.typ = type_pair
|
|
& sexp_is_ellipsis(ast.val_cdr.val_car)
|
|
& sexp_is_pattern(ast.val_cdr.val_cdr)
|
|
then true
|
|
|
|
/* List of templates: (<template_element> ...) */
|
|
/* Pair of templates: (<template_element> . <template>) */
|
|
/* Where <template_element> is <template> <ellipsis> */
|
|
else if ast.typ = type_pair
|
|
& sexp_is_template(ast.val_car)
|
|
& sexp_is_pattern(ast.val_cdr)
|
|
then true
|
|
|
|
/* TODO: Hashtag notation
|
|
(https://people.csail.mit.edu/jaffer/r5rs/Pattern-language.html)
|
|
*/
|
|
|
|
else false
|
|
|
|
function sexp_is_syntax_rule (ast: sexp_ast): bool =
|
|
ast <> nil
|
|
& ast.typ = type_pair
|
|
& sexp_is_pattern(ast.val_car)
|
|
& ast.val_cdr <> nil
|
|
& ast.val_cdr.typ = type_pair
|
|
& ast.val_cdr.val_cdr.typ = type_nil
|
|
& sexp_is_template(ast.val_cdr.val_car)
|
|
|
|
function sexp_is_syntax_rules (ast: sexp_ast): bool =
|
|
if ast <> nil | ast.typ <> type_pair
|
|
then false
|
|
|
|
else if ast.val_car.typ = type_symbol
|
|
& ast.val_car.val_s = "syntax-rules"
|
|
& ast.val_cdr.typ = type_pair
|
|
& sexp_is_literals_list(ast.val_cdr.val_car)
|
|
then let var rule_head := ast.val_cdr.val_cdr
|
|
var correct := true
|
|
in while correct
|
|
& rule_head.typ <> type_nil
|
|
|
|
do ( if not( rule_head.typ = type_pair
|
|
& sexp_is_syntax_rule(rule_head.val_car) )
|
|
then correct := false
|
|
; rule_head := rule_head.val_cdr )
|
|
; correct
|
|
end
|
|
|
|
else false
|
|
|
|
function compile_syntax_rules (ast: sexp_ast): vm_insn_list =
|
|
let
|
|
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)
|
|
; single_insn(atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r)) )
|
|
end
|
|
|
|
function compile_define (ast: sexp_ast): vm_insn_list =
|
|
|
|
/* Standard define form: (define <variable> <expression>) */
|
|
if ast.val_cdr.val_car.typ = type_symbol
|
|
& ast.val_cdr.val_cdr.val_cdr.typ = type_nil
|
|
then let var symbol := ast.val_cdr.val_car.val_s
|
|
var insns_body := compile_rec(ast.val_cdr.val_cdr.val_car, false)
|
|
|
|
var pos_l := ast.pos_l
|
|
var pos_r := ast.pos_r
|
|
|
|
/* Create list of instructions */
|
|
in app_insn (insns_body, OPCODE_SETG, 0, symbol, pos_l, pos_r)
|
|
; app_insn2(insns_body, OPCODE_PUSH, VALUE_UNSPECIFIED, pos_l, pos_r)
|
|
|
|
/* Check variable is not reserved */
|
|
; if is_reserved(symbol)
|
|
then compile_error(concat5( "Attempting to define \""
|
|
, symbol
|
|
, "\". This is not allowed, as \""
|
|
, symbol
|
|
, "\" is a reserved keyword.")
|
|
, ast)
|
|
|
|
/* Return */
|
|
; insns_body
|
|
end
|
|
|
|
/* Below handles both special forms of define, by
|
|
* transforming structure: */
|
|
/* (define (<variable> <formals>) <body>) */
|
|
/* (define (<variable> . <formal>) <body>) */
|
|
else if ast.val_cdr.val_car.typ = type_pair
|
|
& ast.val_cdr.val_car.val_car.typ = type_symbol
|
|
& ast.val_cdr.val_cdr.val_cdr.typ = type_nil
|
|
then let var alt_ast := pair_val( ast.val_car,
|
|
pair_val( ast.val_cdr.val_car.val_car,
|
|
pair_val( pair_val( sym_val("lambda"),
|
|
pair_val( ast.val_cdr.val_car.val_cdr
|
|
, ast.val_cdr.val_cdr)),
|
|
nil_val())))
|
|
|
|
in set_tree_positions(alt_ast, ast.pos_l, ast.pos_r)
|
|
/*; print("Transformed:\n From: ")
|
|
; print(value_to_string(ast))
|
|
; print("\n Into: ")
|
|
; print(value_to_string(alt_ast))
|
|
; print("\n") */
|
|
; compile_define(alt_ast)
|
|
end
|
|
|
|
/* TODO: Support all variations */
|
|
|
|
else (compile_error( "Define does not fit correct form. Should be one of:\n\
|
|
\ (define <variable> <expression>)\n\
|
|
\ (define (<variable> <formals>) <body>)\n\
|
|
\ (define (<variable> . <formal>) <body>)"
|
|
, 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 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
|
|
|
|
/* Throw error on free standing (). Must be either
|
|
* quoted, or exist in special form. */
|
|
else if ast.typ = type_nil then
|
|
( compile_error("Attempting to compile free-standing (). This is not allowed.\n Must use \"'()\", if nil value is wanted.", ast)
|
|
; nil )
|
|
|
|
/* 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)
|
|
|
|
/* If statements */
|
|
else if ast.val_car <> nil
|
|
& ast.val_car.val_s = "if"
|
|
then let var insns_test := compile_rec(ast.val_cdr.val_car, false)
|
|
var insns_then := compile_rec(ast.val_cdr.val_cdr.val_car, can_tail_call)
|
|
var insns_else := if ast.val_cdr.val_cdr.val_cdr.typ = type_pair
|
|
then compile_rec(ast.val_cdr.val_cdr.val_cdr.val_car, can_tail_call)
|
|
else compile_rec(VALUE_UNSPECIFIED, can_tail_call)
|
|
|
|
var jump_then := sexp_ast_length(insns_then) + 1
|
|
var jump_else := sexp_ast_length(insns_else) + 1 + 1
|
|
|
|
var pos_l := ast.pos_l
|
|
var pos_r := ast.pos_r
|
|
|
|
in app_insn(insns_test, OPCODE_CSKIP, 0, "" , pos_l, pos_r)
|
|
; app_insn(insns_test, OPCODE_DGOTO, jump_else, "" , pos_l, pos_r)
|
|
; concat_lists(insns_test, insns_else)
|
|
; app_insn(insns_test, OPCODE_DGOTO, jump_then, "" , pos_l, pos_r)
|
|
; concat_lists(insns_test, insns_then)
|
|
; insns_test
|
|
end
|
|
|
|
/* Define statements */
|
|
else if ast.val_car <> nil & ast.val_car.val_s = "define"
|
|
then compile_define(ast)
|
|
|
|
/* Syntax define statements */
|
|
else if ast.val_car <> nil & ast.val_car.val_s = "define-syntax"
|
|
then ( compile_error("Please do not compile define-syntax", ast)
|
|
; single_insn(atom_to_insn(VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r)))
|
|
|
|
|
|
/* Syntax rules expression */
|
|
else if ast.val_car <> nil & ast.val_car.val_s = "syntax-rules"
|
|
then compile_syntax_rules(ast)
|
|
|
|
/* Begin expressions */
|
|
else if ast.val_car <> nil & ast.val_car.val_s = "begin"
|
|
then let var insns := vm_insn_list { first = nil, last = nil }
|
|
var head := ast.val_cdr
|
|
|
|
in while head <> nil & head.typ = type_pair
|
|
do ( if head <> ast.val_cdr
|
|
then app_insn(insns, OPCODE_POP, 0, "", ast.pos_l, ast.pos_r)
|
|
; concat_lists(insns, compile_rec(head.val_car, false))
|
|
; head := head.val_cdr )
|
|
; insns
|
|
end
|
|
|
|
/* Quote expressions */
|
|
else if ast.val_car <> nil & ast.val_car.val_s = "quote"
|
|
then let var datum := ast.val_cdr.val_car
|
|
|
|
in tail_position_one( vm_insn { opcode = OPCODE_PUSH
|
|
, arg1 = 0
|
|
, arg2 = ""
|
|
, arg3 = datum
|
|
, pos_l = ast.pos_l
|
|
, pos_r = 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 */
|
|
else if ast.val_car <> nil & ast.val_car.val_s = "set!"
|
|
then let var sym := ast.val_cdr.val_car.val_s
|
|
var exp_insns := compile_rec(ast.val_cdr.val_cdr.val_car, false)
|
|
|
|
in app_insn (exp_insns, OPCODE_SET, 0, sym, ast.pos_l, ast.pos_r)
|
|
; app_insn2(exp_insns, OPCODE_PUSH, VALUE_UNSPECIFIED, ast.pos_l, ast.pos_r)
|
|
; exp_insns
|
|
end
|
|
|
|
/* Lambda expressions */
|
|
else if ast.val_car <> nil & ast.val_car.val_s = "lambda"
|
|
then let var insns_body := compile_rec(ast.val_cdr.val_cdr.val_car, true)
|
|
|
|
var pos_l := ast.pos_l
|
|
var pos_r := ast.pos_r
|
|
|
|
function build_insns_arguments (args: sexp_ast, derp: vm_insn_list_link): vm_insn_list_link =
|
|
if args = nil
|
|
| args.typ = type_nil
|
|
| args.val_car = nil
|
|
then derp
|
|
else
|
|
build_insns_arguments( args.val_cdr
|
|
, vm_insn_list_link { insn = vm_insn { opcode = OPCODE_DEF
|
|
, arg1 = 0
|
|
, arg2 = args.val_car.val_s
|
|
, arg3 = nil
|
|
, pos_l = pos_l
|
|
, pos_r = pos_r }
|
|
, next = derp })
|
|
|
|
var insns_ass_args := list(build_insns_arguments(ast.val_cdr.val_car, nil))
|
|
|
|
var jump_lambda := sexp_ast_length(insns_body)
|
|
+ sexp_ast_length(insns_ass_args)
|
|
+ 1
|
|
|
|
var insns := vm_insn_list { first = nil, last = nil }
|
|
|
|
in app_insn(insns, OPCODE_DEFFUN, 2, "", pos_l, pos_r)
|
|
; app_insn(insns, OPCODE_DGOTO, jump_lambda, "" , pos_l, pos_r)
|
|
; concat_lists(insns, insns_ass_args)
|
|
; concat_lists(insns, insns_body)
|
|
; insns
|
|
end
|
|
|
|
/* 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)
|
|
var fun := env_elem.val_car.val_cdr
|
|
in stack_push(stack, ast)
|
|
/*; print("Running ")
|
|
; print(value_to_string(fun))
|
|
; print(" as macro\n")*/
|
|
; if fun <> nil & fun.typ <> type_closure
|
|
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 */
|
|
else let var num_args := 0
|
|
var args_insns := vm_insn_list { first = nil, last = nil }
|
|
var ast_iter := ast.val_cdr
|
|
|
|
var pos_l := ast.pos_l
|
|
var pos_r := ast.pos_r
|
|
|
|
in while ast_iter <> nil & ast_iter.typ = type_pair
|
|
do ( concat_lists(args_insns, compile_rec(ast_iter.val_car, false))
|
|
; num_args := num_args + 1
|
|
; ast_iter := ast_iter.val_cdr )
|
|
; 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 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
|
|
|
|
var base_insns := compile_rec(ast, false)
|
|
in app_insn (base_insns, OPCODE_EXIT, 0, "", ast.pos_l, ast.pos_r)
|
|
; base_insns
|
|
end
|
|
|
|
function optimize_vm_tape (real_tape: vm_tape): vm_tape =
|
|
let var len := real_tape.length
|
|
var tape := real_tape.tape
|
|
in for index := 0 to len - 1
|
|
do if tape[index+0].opcode = OPCODE_PUSH
|
|
& tape[index+1].opcode = OPCODE_POP
|
|
then ( tape[index+0] := noop_insn( tape[index+0].pos_l
|
|
, tape[index+0].pos_r )
|
|
; tape[index+1] := noop_insn( tape[index+1].pos_l
|
|
, tape[index+1].pos_r ))
|
|
else if tape[index+0].opcode = OPCODE_DEF
|
|
& tape[index+1].opcode = OPCODE_LOAD
|
|
& tape[index+0].arg2 = tape[index+1].arg2
|
|
then ( tape[index+1] := tape[index+0]
|
|
; tape[index+0] := vm_insn { opcode = OPCODE_DUPL
|
|
, arg1 = 0
|
|
, arg2 = ""
|
|
, arg3 = nil
|
|
, pos_l = tape[index+1].pos_l
|
|
, pos_r = tape[index+1].pos_r })
|
|
; real_tape
|
|
end
|
|
|
|
function insn_to_string (insn: vm_insn): string =
|
|
if insn = nil
|
|
then ( print("Encountered missing instruction in insn_to_string!\n")
|
|
; "!!!" )
|
|
else if insn.opcode < 0
|
|
| vm_insn_num_opcodes <= insn.opcode
|
|
| vm_insn_info[insn.opcode] = nil
|
|
|
|
then ( print(concat5( "Encountered unknown opcode "
|
|
, int_to_string(insn.opcode)
|
|
, " in insn_to_string!\n"
|
|
, "", ""))
|
|
; "???" )
|
|
else if insn.opcode = OPCODE_DGOTO & insn.arg1 = 1
|
|
then "NOOP"
|
|
else
|
|
let var info := vm_insn_info[insn.opcode]
|
|
in concat5( info.mnemonic
|
|
, if info.uses_arg1
|
|
then concat(" ", int_to_string(insn.arg1))
|
|
else ""
|
|
, if info.uses_arg2
|
|
then concat5(" \"", insn.arg2, "\"", "", "")
|
|
else ""
|
|
, if info.uses_arg3
|
|
then concat(" ", value_to_string(insn.arg3))
|
|
else ""
|
|
, "")
|
|
end
|
|
|
|
function tape_to_string_range (tape: vm_tape, first:int, last:int): string =
|
|
let var str := "TAPE\n"
|
|
var index := first
|
|
var real_tape := tape.tape
|
|
var last := if last < 0 then tape.filled + last
|
|
else last
|
|
var ln_width := size(int_to_string(last))
|
|
|
|
function repeat (str: string, i: int): string =
|
|
if i <= 0
|
|
then ""
|
|
else concat(str, repeat(str, i-1))
|
|
|
|
function line_number (i: int): string =
|
|
let var num_str := int_to_string(i)
|
|
in concat(repeat(" ", ln_width-size(num_str)), num_str)
|
|
end
|
|
|
|
in while index <= last
|
|
do ( str := concat5( str
|
|
, line_number(index)
|
|
, " "
|
|
, insn_to_string(real_tape[index])
|
|
, "\n")
|
|
; index := index + 1 )
|
|
; str := concat(str, "EPAT")
|
|
; str
|
|
end
|
|
|
|
function tape_to_string (tape: vm_tape): string =
|
|
tape_to_string_range(tape, 0, tape.filled)
|
|
|
|
/* Virtual Machine execution */
|
|
|
|
function vm_run ( tape : vm_tape
|
|
, ip : int
|
|
, stack : vm_stack
|
|
, env : vm_env
|
|
, source: string
|
|
, global_env : vm_env ) =
|
|
|
|
let var tape_info := tape
|
|
var tape := tape.tape
|
|
var continue := true
|
|
var ignore := ( if DEBUG_PRINT_STACK
|
|
then print("Entered VM instance\n")
|
|
; "")
|
|
|
|
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_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_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 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)
|
|
; ip := ip + 1
|
|
end
|
|
|
|
else if tape[ip].opcode = OPCODE_PUSH
|
|
then ( stack_push(stack, tape[ip].arg3)
|
|
; ip := ip + 1 )
|
|
|
|
else if tape[ip].opcode = OPCODE_CSKIP
|
|
then let var arg1 := stack_pop(stack)
|
|
in ip := ip + if is_truthy(arg1)
|
|
then 1
|
|
else 2
|
|
end
|
|
|
|
else if tape[ip].opcode = OPCODE_GOTO
|
|
then ip := tape[ip].arg1
|
|
|
|
else if tape[ip].opcode = OPCODE_DGOTO
|
|
then ip := ip + tape[ip].arg1
|
|
|
|
else if tape[ip].opcode = OPCODE_DUPL
|
|
then let var arg1 := stack_seek_elem(stack, tape[ip].arg1)
|
|
in if arg1 = nil
|
|
then run_error("Stack too shallow!")
|
|
else ( stack_push(stack, arg1.value)
|
|
; ip := ip + 1 )
|
|
end
|
|
|
|
else if tape[ip].opcode = OPCODE_SWITCH
|
|
then let var arg1 := stack_pop(stack)
|
|
var arg2 := stack_pop(stack)
|
|
in stack_push(stack, arg1)
|
|
; stack_push(stack, arg2)
|
|
; ip := ip + 1
|
|
end
|
|
|
|
else if tape[ip].opcode = OPCODE_CALL
|
|
then let var call_name_pos := stack_seek_elem(stack, tape[ip].arg1)
|
|
var return_ip := ip + 1
|
|
var return_env := env
|
|
|
|
in if call_name_pos = nil
|
|
then run_error("Stack too shallow!")
|
|
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_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.val_car.val_cdr)
|
|
; ip := ip + 1 )
|
|
else run_error(concat5( "Attempting to access unknown variable \""
|
|
, tape[ip].arg2
|
|
, "\"\n Environment looks like "
|
|
, env_to_string(env)
|
|
, ""))
|
|
end
|
|
|
|
else if tape[ip].opcode = OPCODE_DEF
|
|
then let var value := stack_pop(stack)
|
|
var new_env := env_push(env, tape[ip].arg2, value)
|
|
in env := new_env
|
|
; ip := ip + 1
|
|
end
|
|
|
|
else if tape[ip].opcode = OPCODE_SETG
|
|
then let var value := stack_pop(stack)
|
|
var new_env := global_env_push(global_env, tape[ip].arg2, value)
|
|
in env := new_env
|
|
; ip := ip + 1
|
|
end
|
|
|
|
else if tape[ip].opcode = OPCODE_DEFFUN
|
|
then ( stack_push(stack, fun_val(ip + tape[ip].arg1, env))
|
|
; ip := ip + 1 )
|
|
|
|
else if tape[ip].opcode = OPCODE_RET
|
|
then let var return_to := stack_destroy_elem(stack, tape[ip].arg1)
|
|
in if return_to = nil
|
|
then /*run_error("Stack too shallow!")*/
|
|
/* TODO: Improve */ continue := false
|
|
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_car)
|
|
end
|
|
|
|
else if tape[ip].opcode = OPCODE_POP
|
|
then ( stack_pop(stack)
|
|
; ip := ip + 1 )
|
|
|
|
else if tape[ip].opcode = OPCODE_OUTPUT
|
|
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 output non-string value ", value_to_string(head)))
|
|
else ( print(head.val_s)
|
|
; ip := ip + 1 )
|
|
end
|
|
|
|
else if tape[ip].opcode = OPCODE_TOSTR
|
|
then let var head := stack_pop(stack)
|
|
in if head = nil then run_error("Stack too shallow!")
|
|
; stack_push(stack, str_val(value_to_string(head)))
|
|
; if ip >= 0 then ip := ip + 1
|
|
end
|
|
|
|
else if tape[ip].opcode = OPCODE_CONS
|
|
then let var cdr := stack_pop(stack)
|
|
var car := stack_pop(stack)
|
|
|
|
in if cdr = nil | car = nil then run_error("Stack too shallow!")
|
|
; stack_push(stack, pair_val(car, cdr))
|
|
; if ip >= 0 then ip := ip + 1
|
|
end
|
|
|
|
else if tape[ip].opcode = OPCODE_CAR
|
|
then let var head := stack_pop(stack)
|
|
in if head = nil then run_error("Stack too shallow!")
|
|
else if not(is_pair(head))
|
|
then run_error(concat("Cannot index into non-pair value", value_to_string(head)))
|
|
else ( stack_push(stack, head.val_car)
|
|
; ip := ip + 1 )
|
|
end
|
|
|
|
else if tape[ip].opcode = OPCODE_CDR
|
|
then let var head := stack_pop(stack)
|
|
in if head = nil then run_error("Stack too shallow!")
|
|
else if not(is_pair(head))
|
|
then run_error(concat("Cannot index into non-pair value", value_to_string(head)))
|
|
else ( stack_push(stack, head.val_cdr)
|
|
; ip := ip + 1 )
|
|
end
|
|
|
|
|
|
else if tape[ip].opcode = OPCODE_SET
|
|
then let var head := stack_pop(stack)
|
|
var sym := tape[ip].arg2
|
|
var elem := env_seek_elem(env, sym)
|
|
in if head = nil
|
|
then run_error("Stack too shallow!")
|
|
else if elem = nil
|
|
then run_error(concat5( "Attempting to set unknown variable \""
|
|
, sym
|
|
, "\"\n Environment looks like "
|
|
, env_to_string(env)
|
|
, ""))
|
|
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, nil, nil, nil)) /* TODO: env_macro */
|
|
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
|
|
|
|
else if tape[ip].opcode = OPCODE_EXIT
|
|
then ( if tape[ip].arg1
|
|
then TRIGGERED_EXIT := true
|
|
; continue := false )
|
|
|
|
else run_error(concat("Encountered unknown opcode "
|
|
, int_to_string(tape[ip].opcode)))
|
|
|
|
function run_error (errmsg: string) =
|
|
let
|
|
in print("Tiger-scheme runtime error\n ")
|
|
; print(errmsg)
|
|
; print("\n At instruction ")
|
|
; print(int_to_string(ip))
|
|
; print(": ")
|
|
; print(insn_to_string(tape[ip]))
|
|
; print("\n")
|
|
; if tape[ip] <> nil then
|
|
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(" Scheme: ")
|
|
; print(safe_substring( source
|
|
, at_char(tape[ip].pos_l)
|
|
, at_char(tape[ip].pos_r) ))
|
|
; print("\n")
|
|
; print(" Source: ")
|
|
; print(repr_pos_l)
|
|
; if repr_pos_l <> repr_pos_r
|
|
then ( print(" to ")
|
|
; print(repr_pos_r) )
|
|
; print("\n")
|
|
end
|
|
; continue := false
|
|
; TRIGGERED_EXIT := true
|
|
end
|
|
|
|
in while continue & ip < tape_info.filled & not(TRIGGERED_EXIT)
|
|
do ( vm_update()
|
|
; if DEBUG_PRINT_STACK
|
|
then ( print("[")
|
|
; print(int_to_string(ip))
|
|
; print("]: ")
|
|
; print(stack_to_string(stack))
|
|
; print("\n") ))
|
|
|
|
; if DEBUG_PRINT_STACK
|
|
then print("Exit VM instance\n")
|
|
end
|
|
|
|
/* Ready for running toplevel */
|
|
|
|
var tape := tape_new(1000)
|
|
var ignore := ( tape_append(tape, STD_LIB)
|
|
; "Ignore!" )
|
|
|
|
var stack := stack_new()
|
|
|
|
/* Perform reading of toplevel */
|
|
|
|
function read_matching_parantheses (): string =
|
|
let var depth := 0
|
|
var char := "BAD SHIT HAPPENED"
|
|
var text := ""
|
|
in while char <> ""
|
|
do ( char := getchar()
|
|
; text := concat(text, char)
|
|
; if char = "("
|
|
then depth := depth + 1
|
|
else if char = ")"
|
|
then ( depth := depth - 1
|
|
; if depth = 0 then break ))
|
|
; text
|
|
end
|
|
|
|
var env_global := env_new(ENV_STD)
|
|
var env_macro := env_new(nil_val())
|
|
|
|
in print("Ready for the scheming Tiger?\n")
|
|
; let var text := "BAD SHIT HAPPENED"
|
|
var env := env_global
|
|
|
|
in while text <> "" & not(TRIGGERED_EXIT)
|
|
do let var text := read_matching_parantheses()
|
|
|
|
var macro_name := "" /* Not macro is "" */
|
|
|
|
var sexp := parse_string(text)
|
|
var sexp_compile :=
|
|
if sexp.typ = type_pair
|
|
& sexp.val_car.typ = type_symbol
|
|
& sexp.val_car.val_s = "define-syntax"
|
|
then ( macro_name := sexp.val_cdr.val_car.val_s
|
|
; sexp.val_cdr.val_cdr.val_car )
|
|
else sexp
|
|
|
|
var insns := compile_to_vm(sexp_compile, env_macro, tape, env_global)
|
|
var start_index := tape_append(tape, insns)
|
|
in ()
|
|
; if DEBUG_PRINT_PARSED
|
|
then ( print("Parsed: ")
|
|
; print(value_to_string(sexp))
|
|
; print("\n"))
|
|
|
|
; if DEBUG_PRINT_TAPE
|
|
then ( print("Tape:\n")
|
|
; print(tape_to_string_range(tape, start_index, -1))
|
|
; print("\n") )
|
|
|
|
; let var stack := stack_new()
|
|
var value : scheme_value := nil
|
|
in if 0 <= start_index
|
|
then vm_run(tape, start_index, stack, env, text, env_global)
|
|
|
|
; if macro_name <> ""
|
|
then ( value := stack_pop(stack)
|
|
/*; print("New macro \"")
|
|
; print(macro_name)
|
|
; print("\": ")
|
|
; print(value_to_string(value))
|
|
; print("\n")*/
|
|
; if value <> nil & value.typ <> type_closure
|
|
then ( print("Attempting to save non-function as macro!\n")
|
|
; TRIGGERED_EXIT := true )
|
|
; global_env_push( env_macro
|
|
, macro_name
|
|
, value )
|
|
; macro_name := "")
|
|
end
|
|
end
|
|
end
|
|
|
|
; print("Stack: ")
|
|
; print(stack_to_string(stack))
|
|
; print("\n")
|
|
|
|
end
|
|
|