2018-12-03 14:06:12 +00:00
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
/* Basic utility */
function concatm ( s1: string
, s2: string
, s3: string
, s4: string
, s5: string ): string =
concat(s1, concat(s2, concat(s3, concat(s4, s5))))
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))
2018-12-04 14:35:27 +00:00
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)
; substring(str, i_start, i_end - i_start + 1) )
2018-12-03 14:06:12 +00:00
/* Scheme value system */
2018-12-04 14:35:27 +00:00
type type_type = int
type scheme_value = { typ : type_type
2018-12-03 14:06:12 +00:00
, val_i : int
, val_s : string
, val_e : scheme_environment
, val_car : scheme_value
, val_cdr : scheme_value
, pos_l: int
, pos_r: int }
type vm_env_key = string
type vm_env_elem = scheme_value
type vm_env = { key: vm_env_key, value: vm_env_elem, next: vm_env }
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 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")
; "<???>" )
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.typ = type_nil
then let
in concatm ( 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.typ = type_pair
in concatm ( 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")
; "<???>" )
in val_rec(base_v, true)
end
function is_truthy (e: scheme_value): bool =
2018-12-04 14:35:27 +00:00
e <> nil
& e.typ <> type_false
& (IS_NIL_TRUTHY | e.typ <> type_nil)
2018-12-03 14:06:12 +00:00
function is_integer (e: scheme_value): bool =
2018-12-04 14:35:27 +00:00
e <> nil & e.typ = type_integer
2018-12-03 14:06:12 +00:00
function is_string (e: scheme_value): bool =
2018-12-04 14:35:27 +00:00
e <> nil &e.typ = type_string
2018-12-03 14:06:12 +00:00
function is_function (e: scheme_value): bool =
2018-12-04 14:35:27 +00:00
e <> nil &e.typ = type_closure
2018-12-03 14:06:12 +00:00
function is_pair (e: scheme_value): bool =
2018-12-04 14:35:27 +00:00
e <> nil &e.typ = type_pair
2018-12-03 14:06:12 +00:00
function is_symbol (e: scheme_value): bool =
2018-12-04 14:35:27 +00:00
e <> nil &e.typ = type_symbol
2018-12-03 14:06:12 +00:00
function int_val (i: int): scheme_value =
scheme_value { typ = type_integer
, val_i = i
, val_s = ""
, val_e = nil
, val_car = nil
, val_cdr = nil
, pos_l = -1
, pos_r = -1 }
function str_val (s: string): scheme_value =
scheme_value { typ = type_string
, val_i = 0
, val_s = s
, val_e = nil
, val_car = nil
, val_cdr = nil
, pos_l = -1
, pos_r = -1 }
function fun_val (i: int, env: scheme_environment): scheme_value =
scheme_value { typ = type_closure
, val_i = i
, val_s = ""
, val_e = env
, val_car = nil
, val_cdr = nil
, pos_l = -1
, pos_r = -1 }
function bool_val (i: int): scheme_value =
scheme_value { typ = if (i <> 0)
then type_true
else type_false
, val_i = i <> 0
, val_s = ""
, val_e = nil
, val_car = nil
, val_cdr = nil
, pos_l = -1
, pos_r = -1 }
function pair_val (car: scheme_value, cdr: scheme_value): scheme_value =
scheme_value { typ = type_pair
, val_i = 0
, val_s = ""
, val_e = nil
, val_car = car
, val_cdr = cdr
, pos_l = -1
, pos_r = -1 }
function sym_val (sym: string): scheme_value =
scheme_value { typ = type_symbol
, val_i = 0
, val_s = sym
, val_e = nil
, val_car = nil
, val_cdr = nil
, pos_l = -1
, pos_r = -1 }
function nil_val (): scheme_value =
scheme_value { typ = type_nil
, val_i = 0
, val_s = ""
, val_e = nil
, val_car = nil
, val_cdr = nil
, pos_l = -1
, pos_r = -1 }
var VALUE_UNSPECIFIED := nil_val()
/* Parsing */
type sexp_ast = scheme_value
function parse_string (str: string): sexp_ast =
let var index := 0
function is_ws (index: int): int =
let var ascii := ord(substring(str, index, 1))
in ascii = 32 | ascii = 9 | ascii = 10
end
function is_left_paren (index: int): int =
let var ascii := ord(substring(str, index, 1))
in ascii = 40
end
function is_right_paren (index: int): int =
let var ascii := ord(substring(str, index, 1))
in ascii = 41
end
function is_tick (index: int): int =
let var ascii := ord(substring(str, index, 1))
in ascii = ord("'")
end
function is_symbol (index: int): int =
let var ascii := ord(substring(str, index, 1))
in not ( ascii = 9
| ascii = 10
| ascii = 32
| ascii = 40
| ascii = 41
| ascii = ord("'") )
end
function sexp_nil (pos_l: int, pos_r: int): sexp_ast =
sexp_ast { typ = type_nil
, val_i = 0
, val_s = ""
, val_e = nil
, val_car = nil
, val_cdr = nil
, pos_l = pos_l
, pos_r = pos_r }
function sexp_atom (sym: string, pos_l: int, pos_r: int): sexp_ast =
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_quote (datum: sexp_ast, pos_l: int, pos_r: int): sexp_ast =
sexp_pair( sexp_atom( "quote", pos_l, pos_r)
, sexp_pair( datum, sexp_nil(pos_l, pos_r)
, pos_l, pos_r)
, pos_l, pos_r )
function sexp_pair ( car: sexp_ast
, cdr: sexp_ast
, pos_l: int
, pos_r: int): sexp_ast =
sexp_ast { typ = type_pair
, val_i = 0
, val_s = ""
, val_e = nil
, val_car = car
, val_cdr = cdr
, pos_l = pos_l
, pos_r = pos_r }
function ignore_ws () =
while index < size(str) & is_ws(index)
do index := index + 1
function parse_rec (): sexp_ast =
( ignore_ws()
; if is_symbol(index)
then let var index_start := index
in while is_symbol(index)
do index := index + 1
; sexp_atom( substring(str, index_start, index - index_start)
, index_start
, index - 1 )
end
else if is_tick(index)
then let var index_start := index
var datum := ( index := index + 1
; parse_rec() )
var exp := sexp_quote(datum, index_start, index)
in exp
end
else if is_left_paren(index)
then let var sexp : sexp_ast := nil
var sexp_last : sexp_ast := nil
var index_start := index
var most_right := index
in index := index + 1 /* Position after index */
; while index < size(str) & not(is_right_paren(index))
do let var parsed := parse_rec()
var link := sexp_pair( parsed
, sexp_nil(index, index)
, 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 := max(link.pos_r, most_right)
; ignore_ws()
end
/* Error handling */
; if index >= size(str)
then parse_error("Misaligned parenthesis")
/*else if index = index_start + 1
then parse_error("Encountered unit
expression (); is not allowed
Scheme.")*/
/* Give correct positions */
; sexp_last := sexp
; while sexp_last <> nil
do ( sexp_last.pos_r := most_right
; sexp_last := sexp_last.val_cdr )
; if sexp <> nil
then ( sexp.pos_l := sexp.pos_l - 1
; sexp.pos_r := sexp.pos_r + 1 )
/* Continue with stuff */
; index := index + 1
; if sexp = nil
2018-12-04 14:35:27 +00:00
then sexp_nil(index_start, most_right)
2018-12-03 14:06:12 +00:00
else sexp
end
else (parse_error("Error: I don't even!"); nil))
function parse_error(errmsg: string) =
let
in print("Tiger-scheme parse error\n ")
; print(errmsg)
2018-12-04 14:35:27 +00:00
; print("\n At index: ")
2018-12-03 14:06:12 +00:00
; print(int_to_string(index))
2018-12-04 14:35:27 +00:00
; print("\n Nearby: ")
; print(safe_substring(str, index-10, index+10))
2018-12-03 14:06:12 +00:00
; print("\n")
end
in parse_rec()
end
function sexp_ast_to_string (ast: sexp_ast): string =
let function tostr_rec (ast: sexp_ast, nil_implicit: int): string =
if ast = nil then "SOMEBODY FUCKED UP"
else if ast.typ = type_nil & nil_implicit
then ""
else if ast.typ = type_pair & ast.val_car.typ <> type_pair
then let var s_left := tostr_rec(ast.val_car, 0)
var s_right := tostr_rec(ast.val_cdr, 1)
in concat(s_left, if s_right <> ""
then concat(" ", s_right)
else "")
end
else if ast.typ = type_pair
then let var s_left := tostr_rec(ast.val_car, 0)
var s_right := tostr_rec(ast.val_cdr, 1)
in concat("(",
concat(s_left,
concat(")", if s_right <> ""
then concat(" ", s_right)
else "")))
end
else ast.val_s
in concat("(", concat(tostr_rec(ast, 0), ")"))
end
/**** Instructions ****/
type vm_insn = { opcode: int
, arg1: int
, arg2: string
, arg3: scheme_value
, pos_l: int
, pos_r: int }
type vm_tape_tape = array of vm_insn
type vm_tape = { length: 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
2018-12-04 14:35:27 +00:00
var vm_insn_num_opcodes := 0
2018-12-03 14:06:12 +00:00
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(concatm( "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_OUTPUT, "OUTPUT", 0, 0, 0)
; code(OPCODE_TOSTR, "TOSTR", 0, 0, 0)
; code(OPCODE_CONS, "CONS", 0, 0, 0)
; code(OPCODE_CAR, "CAR", 0, 0, 0)
; code(OPCODE_CDR, "CDR", 0, 0, 0)
; code(OPCODE_SET, "SET", 0, 1, 0)
; for i := 1 to expected_number_opcodes - 1
do if a[i] <> nil & a[i-1] = nil
then print(concatm("Error: Opcode info array incorrectly initialized!\n Opcode "
, 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: int, pos_r: int): 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 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(concat("Error: Instruction list invariant not maintained! First is ", concat(if a.first = nil then "" else "not ", concat( "nil, second is ", concat(if a.last = nil then "" else "not ", "nil\n")))))
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: int, pos_r: int) =
( 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: int, pos_r: int) =
( 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: int, pos_r: int) =
if return_now
then app_insn(prev_insns, OPCODE_RET, 1, "", pos_l, pos_r)
function tail_position_one (insn: vm_insn, return_now: bool, pos_l: int, pos_r: int): vm_insn_list =
let var insns := single_insn(insn)
in tail_position(insns, return_now, pos_l, 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 STD_LIB_ENV: vm_env := nil
2018-12-04 14:35:27 +00:00
var STD_LIB_ID_FUNCTION: scheme_value := nil
2018-12-03 14:06:12 +00:00
var STD_LIB := let var first_insn := noop_insn(-1, -1)
var std_insns := single_insn(first_insn)
function app (opcode: int, arg1: int, arg2: string) =
app_insn(std_insns, opcode, arg1, arg2, -1, -1)
function app2 (opcode: int, arg3: scheme_value) =
app_insn2(std_insns, opcode, arg3, -1, -1)
function stdval (name: string, value: scheme_value) =
STD_LIB_ENV := vm_env { key = name
, value = value
, next = STD_LIB_ENV }
2018-12-04 14:35:27 +00:00
function tape_pos (): int =
insn_list_length(std_insns)
2018-12-03 14:06:12 +00:00
function stdfun (name: string) =
2018-12-04 14:35:27 +00:00
stdval(name, fun_val(tape_pos(), nil))
2018-12-03 14:06:12 +00:00
in ()
/* Nil */
; if HAS_NIL_SYMBOL
then stdval("nil", nil_val())
2018-12-04 14:35:27 +00:00
/* Identity function */
; STD_LIB_ID_FUNCTION := fun_val(tape_pos(), nil)
; app(OPCODE_RET, 1, "")
2018-12-03 14:06:12 +00:00
/* Useful standard functions */
; stdfun("display")
; 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, "")
; 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, "")
; first_insn.arg1 := insn_list_length(std_insns)
; std_insns
end
function compile_to_vm (ast: sexp_ast): vm_tape =
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: int, pos_r: int): 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 is_postfix (ast: sexp_ast): int =
(ast <> nil)
& (ast.typ = type_pair)
& (ast.val_car <> nil)
& (ast.val_car.typ <> type_pair)
& (ast.val_car.val_s = "+" | ast.val_car.val_s = "*" | ast.val_car.val_s = ">=")
function op_insn (opcode: int, pos_l: int, pos_r: int): vm_insn =
vm_insn { opcode = opcode
, arg1 = 0
, arg2 = ""
, arg3 = nil
, pos_l = pos_l
, pos_r = pos_r }
function compile_postfix ( sym : string
, num_args : int
, insns : vm_insn_list
, pos_l : int
, pos_r : int
, tail_call: bool ): vm_insn_list =
let var insn := if sym = "+" then op_insn(OPCODE_ADD, pos_l, pos_r)
else if sym = "*" then op_insn(OPCODE_MULT, pos_l, pos_r)
else if sym = ">=" then op_insn(OPCODE_GEQ, pos_l, pos_r)
else (print("Unknown special form"); nil)
in concat_lists(insns, single_insn(insn))
; tail_position(insns, tail_call, pos_l, pos_r)
; insns
end
function sexp_ast_length(insns: vm_insn_list): int =
let function rec (insns: vm_insn_list_link, sum: int): int =
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: int
, pos_r: int ) =
/* 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) ))
2018-12-04 14:35:27 +00:00
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)
; compile_rec(VALUE_UNSPECIFIED, false) )
end
2018-12-03 14:06:12 +00:00
function compile_define_syntax (ast: sexp_ast): vm_insn_list =
2018-12-04 14:35:27 +00:00
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
/* TODO: Improve below */
in app_insn(insns_body, OPCODE_POP, 0, "", pos_l, pos_r)
; app_insn2(insns_body, OPCODE_PUSH, VALUE_UNSPECIFIED, pos_l, pos_r)
; insns_body
2018-12-03 14:06:12 +00:00
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
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)
; 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_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, ast.pos_l, ast.pos_r )
/* 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_define_syntax(ast)
2018-12-04 14:35:27 +00:00
/* Syntax rules expression */
else if ast.val_car <> nil & ast.val_car.val_s = "syntax-rules"
then compile_syntax_rules(ast)
2018-12-03 14:06:12 +00:00
/* 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
, ast.pos_l
, ast.pos_r)
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
/* 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 )
; if is_postfix(ast)
then compile_postfix (ast.val_car.val_s, num_args, args_insns, pos_l, pos_r, can_tail_call)
else let
var insns_head := compile_rec(ast.val_car, false)
/* Below we choose whether to call
* normally, or tail calling (identical
* to returning) */
var call_op := if can_tail_call
then OPCODE_RET
else OPCODE_CALL
in concat_lists( insns_head, args_insns)
; app_insn( insns_head, call_op, num_args, "", pos_l, pos_r)
; insns_head
end
end
function compile_error(errmsg: string, errast: sexp_ast) =
let
in print("Tiger-scheme compile error\n ")
; print(errmsg)
; print("\n For scheme: ")
; print(value_to_string(errast))
; print("\n")
end
function insn_list_to_tape (insns: vm_insn_list): vm_tape =
let var length := insn_list_length(insns)
var tape := vm_tape_tape [length] of nil
var index := 0
var head := insns.first
in while index < length
do ( tape[index] := head.insn
; index := index + 1
; head := head.next )
; vm_tape { length = length, tape = tape }
end
in insn_list_to_tape( concat_lists(copy_list(STD_LIB)
, compile_rec(ast, true)))
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 opcode in insn_to_string!\n")
; "!!!" )
else if insn.opcode < 0
| vm_insn_num_opcodes <= insn.opcode
| vm_insn_info[insn.opcode] = nil
then ( print(concatm( "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 concatm( info.mnemonic
, if info.uses_arg1
then concat(" ", int_to_string(insn.arg1))
else ""
, if info.uses_arg2
then concatm(" \"", insn.arg2, "\"", "", "")
else ""
, if info.uses_arg3
then concat(" ", value_to_string(insn.arg3))
else ""
, "")
end
function tape_to_string (tape: vm_tape): string =
let var str := "TAPE\n"
var index := 0
var real_tape := tape.tape
var length := tape.length
var ln_width := size(int_to_string(tape.length))
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 < length
do ( str := concatm( str
, line_number(index)
, " "
, insn_to_string(real_tape[index])
, "\n")
; index := index + 1 )
; str := concat(str, "EPAT")
; str
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_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(): vm_env =
vm_env { key = GLOBAL_ENV_SENTINEL
, value = bool_val(0)
, next = STD_LIB_ENV }
function env_seek_elem(env: vm_env, key: vm_env_key): vm_env =
let var head := env
in while head <> nil & head.key <> key
do head := head.next
; head
end
function env_push(env: vm_env, key: vm_env_key, value: vm_env_elem): vm_env =
vm_env { key = key
, value = value
, next = env }
function global_env_push (env: vm_env, key: vm_env_key, value: vm_env_elem): vm_env =
let
in if env.key <> GLOBAL_ENV_SENTINEL
then print("Attempting to perform global push to non-global environment")
else env.next := vm_env { key = key
, value = value
, next = env.next }
; env
end
function env_to_string (env: vm_env): string =
let function iter (list: vm_env): string =
if list = nil then ""
else concat("(",
concat(list.key,
concat(": ",
concat(value_to_string(list.value), if list.next <> nil
then concat("), ", iter(list.next))
else ")"))))
in concat("[", concat(iter(env), "]"))
end
/* Tape */
/* 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_size := tape.length
var tape := tape.tape
function vm_update () =
if tape[ip] = nil
then ip := -1
/* Integer binary operators */
else if let var op := tape[ip].opcode
in op = OPCODE_ADD | op = OPCODE_MULT | op = OPCODE_GEQ end
then let var opcode := tape[ip].opcode
var arg2 := stack_pop(stack)
var arg1 := stack_pop(stack)
var val: scheme_value := nil
in if not (is_integer(arg1)) then run_error("Argument #1 to binary operation was not integer")
; if not (is_integer(arg2)) then run_error("Argument #2 to binary operation was not integer")
; 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 (run_error("Impossible!"); bool_val(0))
; stack_push(stack, val)
; if ip >= 0 then 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_e
; call_name_pos.value := fun_val(return_ip, return_env) )
end
else if tape[ip].opcode = OPCODE_LOAD
then let var value_container := env_seek_elem(env, tape[ip].arg2)
in if value_container <> nil
then ( stack_push(stack, value_container.value)
; ip := ip + 1 )
else run_error(concatm( "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!")
else if not(is_function(return_to))
then run_error(concat("Cannot return to non-function value ", value_to_string(return_to)))
else ( ip := return_to.val_i
; env := return_to.val_e)
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(concatm( "Attempting to set unknown variable \""
, sym
, "\"\n Environment looks like "
, env_to_string(env)
, ""))
else ( elem.value := head
; ip := ip + 1 )
end
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 Scheme: ")
2018-12-04 14:35:27 +00:00
; print(safe_substring(source, tape[ip].pos_l, tape[ip].pos_r))
2018-12-03 14:06:12 +00:00
; print("\n")
; ip := -1
end
in while 0 <= ip & ip < tape_size
do ( vm_update()
; if DEBUG_PRINT_STACK
then ( print("[")
; print(int_to_string(ip))
; print("]: ")
; print(stack_to_string(stack))
; print("\n") ))
; if not (0 <= ip & ip < tape_size)
then print("Died due to out of bounds instruction pointer.\n")
end
/* Do stuff */
var test_text := "(begin (define add-three (lambda (x y z) (+ (+ x z) y))) \
\ (define fac (lambda (x) (if (>= x 1) (* x (fac (+ x -1))) 1))) \
\ (define (faca x a) \
\ (if (>= x 1) \
\ (faca (+ x -1) (* x a)) \
\ a)) \
\ (define (f . l) (cdr l)) \
\ (define x 5) \
\ (define y '(1 2 3)) \
\ (display x) (newline) \
\ (display (fac x)) (newline) \
\ (display (faca x 1)) (newline) \
\ (display y) (newline) \
\ (display (car y)) (newline) \
\ (display (cdr y)) (newline) \
\ (set! x 10) \
\ (display x) (newline) \
2018-12-04 14:35:27 +00:00
2018-12-03 14:06:12 +00:00
\ (define-syntax and \
\ (syntax-rules ()\
\ ((and) #t)\
\ ((and test) test)\
\ ((and test1 test2 ...)\
\ (if test1 (and test2 ...) #f))))\
2018-12-04 14:35:27 +00:00
2018-12-03 14:06:12 +00:00
\ (display (and #t #t)) (newline) \
\ (display (and #f #t)) (newline) \
\ (display (and #f #f)) (newline) \
\ (display (and #t #f)) (newline) \
\) "
var ignore := ( print("** Parsing **\n")
; print("Original : ")
; print(test_text)
; print("\n")
; 1)
var sexp_ast := parse_string(test_text)
var ignore := ( print("Parsed : ")
; print(value_to_string(sexp_ast))
; print("\n")
; print("** Compilation **\n")
; 1)
var tape := compile_to_vm(sexp_ast)
var tape := optimize_vm_tape(tape)
var ignore := ( print("Compiled!:\n")
; print(tape_to_string(tape))
; print("\n")
; 1)
var stack := stack_new()
var env := env_new()
in ()
; print("\n** VM **\n")
; vm_run(tape, 0, stack, env, test_text, env)
; print("Stack: ")
; print(stack_to_string(stack))
; print("\n")
end
