Jmaa/tiger-scheme
1
0
Fork 0
Code

Working on macros.

Browse Source
This commit is contained in:
Jon Michael Aanes 2018-12-04 15:35:27 +01:00
parent 4faad40a1b
commit 96cc19b207
1 changed files with 214 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

241
tigerscheme.tig
View File

@ -48,9 +48,22 @@ let /* Booleans */
function is_integer_string (s: string): int = function is_integer_string (s: string): int =
s = int_to_string(string_to_int(s)) 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)
; substring(str, i_start, i_end - i_start + 1) )
/* Scheme value system */ /* Scheme value system */
type scheme_value = { typ : int type type_type = int
type scheme_value = { typ : type_type
, val_i : int , val_i : int
, val_s : string , val_s : string
, val_e : scheme_environment , val_e : scheme_environment
@ -125,22 +138,24 @@ let /* Booleans */
end end
function is_truthy (e: scheme_value): bool = function is_truthy (e: scheme_value): bool =
e.typ <> type_false & (IS_NIL_TRUTHY | e.typ <> type_nil) e <> nil
& e.typ <> type_false
& (IS_NIL_TRUTHY | e.typ <> type_nil)
function is_integer (e: scheme_value): bool = function is_integer (e: scheme_value): bool =
e.typ = type_integer e <> nil & e.typ = type_integer
function is_string (e: scheme_value): bool = function is_string (e: scheme_value): bool =
e.typ = type_string e <> nil &e.typ = type_string
function is_function (e: scheme_value): bool = function is_function (e: scheme_value): bool =
e.typ = type_closure e <> nil &e.typ = type_closure
function is_pair (e: scheme_value): bool = function is_pair (e: scheme_value): bool =
e.typ = type_pair e <> nil &e.typ = type_pair
function is_symbol (e: scheme_value): bool = function is_symbol (e: scheme_value): bool =
e.typ = type_symbol e <> nil &e.typ = type_symbol
function int_val (i: int): scheme_value = function int_val (i: int): scheme_value =
scheme_value { typ = type_integer scheme_value { typ = type_integer
@ -334,9 +349,6 @@ let /* Booleans */
var index_start := index var index_start := index
var most_right := index var most_right := index
function max (a:int, b:int): int =
if a > b then a else b
in index := index + 1 /* Position after index */ in index := index + 1 /* Position after index */
; while index < size(str) & not(is_right_paren(index)) ; while index < size(str) & not(is_right_paren(index))
do let var parsed := parse_rec() do let var parsed := parse_rec()
@ -387,8 +399,7 @@ let /* Booleans */
/* Continue with stuff */ /* Continue with stuff */
; index := index + 1 ; index := index + 1
; if sexp = nil ; if sexp = nil
then ( parse_error("Internal assertion failed") then sexp_nil(index_start, most_right)
; sexp_nil(-1, -1))
else sexp else sexp
end end
else (parse_error("Error: I don't even!"); nil)) else (parse_error("Error: I don't even!"); nil))
@ -397,8 +408,10 @@ let /* Booleans */
let let
in print("Tiger-scheme parse error\n ") in print("Tiger-scheme parse error\n ")
; print(errmsg) ; print(errmsg)
; print("\n At index ") ; print("\n At index: ")
; print(int_to_string(index)) ; print(int_to_string(index))
; print("\n Nearby: ")
; print(safe_substring(str, index-10, index+10))
; print("\n") ; print("\n")
end end
@ -473,7 +486,7 @@ let /* Booleans */
var OPCODE_CDR := 16 var OPCODE_CDR := 16
var OPCODE_SET := 21 var OPCODE_SET := 21
var vm_insn_num_opcodes := 0 var vm_insn_num_opcodes := 0
var vm_insn_info := var vm_insn_info :=
let var expected_number_opcodes := 30 let var expected_number_opcodes := 30
var a := vm_insn_info_l [expected_number_opcodes] of nil var a := vm_insn_info_l [expected_number_opcodes] of nil
@ -608,6 +621,7 @@ let /* Booleans */
var STD_LIB_ENV: vm_env := nil var STD_LIB_ENV: vm_env := nil
var STD_LIB_ID_FUNCTION: scheme_value := nil
var STD_LIB := let var first_insn := noop_insn(-1, -1) var STD_LIB := let var first_insn := noop_insn(-1, -1)
@ -624,8 +638,11 @@ let /* Booleans */
, value = value , value = value
, next = STD_LIB_ENV } , next = STD_LIB_ENV }
function tape_pos (): int =
insn_list_length(std_insns)
function stdfun (name: string) = function stdfun (name: string) =
stdval(name, fun_val(insn_list_length(std_insns), nil)) stdval(name, fun_val(tape_pos(), nil))
in () in ()
@ -633,6 +650,10 @@ let /* Booleans */
; if HAS_NIL_SYMBOL ; if HAS_NIL_SYMBOL
then stdval("nil", nil_val()) then stdval("nil", nil_val())
/* Identity function */
; STD_LIB_ID_FUNCTION := fun_val(tape_pos(), nil)
; app(OPCODE_RET, 1, "")
/* Useful standard functions */ /* Useful standard functions */
; stdfun("display") ; stdfun("display")
; app(OPCODE_TOSTR, 0, "") ; app(OPCODE_TOSTR, 0, "")
@ -730,7 +751,6 @@ let /* Booleans */
in rec(insns.first, 0) in rec(insns.first, 0)
end end
function set_tree_positions ( ast: sexp_ast function set_tree_positions ( ast: sexp_ast
, pos_l: int , pos_l: int
, pos_r: int ) = , pos_r: int ) =
@ -742,17 +762,178 @@ let /* Booleans */
then ( set_tree_positions( ast.val_cdr, pos_l, pos_r) then ( set_tree_positions( ast.val_cdr, pos_l, pos_r)
; set_tree_positions( ast.val_car, pos_l, pos_r) )) ; set_tree_positions( ast.val_car, pos_l, pos_r) ))
function compile_define_syntax (ast: sexp_ast): vm_insn_list = function sexp_is_list_of_type ( ast: sexp_ast
let var syntax_name := ast.val_cdr.val_car.val_s , subtype: type_type ): bool =
var variables := ast.val_cdr.val_cdr.val_car.val_cdr.val_car if ast = nil
var rules := ast.val_cdr.val_cdr.val_car.val_cdr.val_cdr 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)
var check_1 := ( ast.val_cdr.val_cdr.val_cdr.typ = type_nil ) function sexp_is_literals_list ( ast: sexp_ast ): bool =
var check_2 := ( ast.val_cdr.val_cdr.val_car.val_car.typ = type_symbol sexp_is_list_of_type(ast, type_symbol)
& ast.val_cdr.val_cdr.val_car.val_car.val_s = "define-syntax")
/* TODO */ function sexp_is_ellipsis ( ast: sexp_ast ): bool =
in ( compile_error("define-syntax not implemented!", ast) ast <> nil
; list(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
function compile_define_syntax (ast: sexp_ast): vm_insn_list =
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
end end
function compile_define (ast: sexp_ast): vm_insn_list = function compile_define (ast: sexp_ast): vm_insn_list =
@ -849,6 +1030,10 @@ let /* Booleans */
else if ast.val_car <> nil & ast.val_car.val_s = "define-syntax" else if ast.val_car <> nil & ast.val_car.val_s = "define-syntax"
then compile_define_syntax(ast) then compile_define_syntax(ast)
/* Syntax rules expression */
else if ast.val_car <> nil & ast.val_car.val_s = "syntax-rules"
then compile_syntax_rules(ast)
/* Begin expressions */ /* Begin expressions */
else if ast.val_car <> nil & ast.val_car.val_s = "begin" else if ast.val_car <> nil & ast.val_car.val_s = "begin"
then let var insns := vm_insn_list { first = nil, last = nil } then let var insns := vm_insn_list { first = nil, last = nil }
@ -1357,7 +1542,7 @@ let /* Booleans */
; print(": ") ; print(": ")
; print(insn_to_string(tape[ip])) ; print(insn_to_string(tape[ip]))
; print("\n Scheme: ") ; print("\n Scheme: ")
; print(substring(source, tape[ip].pos_l, 1 + tape[ip].pos_r - tape[ip].pos_l)) ; print(safe_substring(source, tape[ip].pos_l, tape[ip].pos_r))
; print("\n") ; print("\n")
; ip := -1 ; ip := -1
end end
@ -1393,12 +1578,14 @@ let /* Booleans */
\ (display (cdr y)) (newline) \ \ (display (cdr y)) (newline) \
\ (set! x 10) \ \ (set! x 10) \
\ (display x) (newline) \ \ (display x) (newline) \
\ (define-syntax and \ \ (define-syntax and \
\ (syntax-rules ()\ \ (syntax-rules ()\
\ ((and) #t)\ \ ((and) #t)\
\ ((and test) test)\ \ ((and test) test)\
\ ((and test1 test2 ...)\ \ ((and test1 test2 ...)\
\ (if test1 (and test2 ...) #f))))\ \ (if test1 (and test2 ...) #f))))\
\ (display (and #t #t)) (newline) \ \ (display (and #t #t)) (newline) \
\ (display (and #f #t)) (newline) \ \ (display (and #f #t)) (newline) \
\ (display (and #f #f)) (newline) \ \ (display (and #f #f)) (newline) \