Working on macros.
This commit is contained in:
parent
4faad40a1b
commit
96cc19b207
241
tigerscheme.tig
241
tigerscheme.tig
|
|
@ -48,9 +48,22 @@ let /* Booleans */
|
|||
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)
|
||||
; substring(str, i_start, i_end - i_start + 1) )
|
||||
|
||||
/* Scheme value system */
|
||||
|
||||
type scheme_value = { typ : int
|
||||
type type_type = int
|
||||
|
||||
type scheme_value = { typ : type_type
|
||||
, val_i : int
|
||||
, val_s : string
|
||||
, val_e : scheme_environment
|
||||
|
|
@ -125,22 +138,24 @@ let /* Booleans */
|
|||
end
|
||||
|
||||
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 =
|
||||
e.typ = type_integer
|
||||
e <> nil & e.typ = type_integer
|
||||
|
||||
function is_string (e: scheme_value): bool =
|
||||
e.typ = type_string
|
||||
e <> nil &e.typ = type_string
|
||||
|
||||
function is_function (e: scheme_value): bool =
|
||||
e.typ = type_closure
|
||||
e <> nil &e.typ = type_closure
|
||||
|
||||
function is_pair (e: scheme_value): bool =
|
||||
e.typ = type_pair
|
||||
e <> nil &e.typ = type_pair
|
||||
|
||||
function is_symbol (e: scheme_value): bool =
|
||||
e.typ = type_symbol
|
||||
e <> nil &e.typ = type_symbol
|
||||
|
||||
function int_val (i: int): scheme_value =
|
||||
scheme_value { typ = type_integer
|
||||
|
|
@ -334,9 +349,6 @@ let /* Booleans */
|
|||
var index_start := 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 */
|
||||
; while index < size(str) & not(is_right_paren(index))
|
||||
do let var parsed := parse_rec()
|
||||
|
|
@ -387,8 +399,7 @@ let /* Booleans */
|
|||
/* Continue with stuff */
|
||||
; index := index + 1
|
||||
; if sexp = nil
|
||||
then ( parse_error("Internal assertion failed")
|
||||
; sexp_nil(-1, -1))
|
||||
then sexp_nil(index_start, most_right)
|
||||
else sexp
|
||||
end
|
||||
else (parse_error("Error: I don't even!"); nil))
|
||||
|
|
@ -397,8 +408,10 @@ let /* Booleans */
|
|||
let
|
||||
in print("Tiger-scheme parse error\n ")
|
||||
; print(errmsg)
|
||||
; print("\n At index ")
|
||||
; print("\n At index: ")
|
||||
; print(int_to_string(index))
|
||||
; print("\n Nearby: ")
|
||||
; print(safe_substring(str, index-10, index+10))
|
||||
; print("\n")
|
||||
end
|
||||
|
||||
|
|
@ -473,7 +486,7 @@ let /* Booleans */
|
|||
var OPCODE_CDR := 16
|
||||
var OPCODE_SET := 21
|
||||
|
||||
var vm_insn_num_opcodes := 0
|
||||
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
|
||||
|
|
@ -608,6 +621,7 @@ let /* Booleans */
|
|||
|
||||
|
||||
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)
|
||||
|
||||
|
|
@ -624,8 +638,11 @@ let /* Booleans */
|
|||
, value = value
|
||||
, next = STD_LIB_ENV }
|
||||
|
||||
function tape_pos (): int =
|
||||
insn_list_length(std_insns)
|
||||
|
||||
function stdfun (name: string) =
|
||||
stdval(name, fun_val(insn_list_length(std_insns), nil))
|
||||
stdval(name, fun_val(tape_pos(), nil))
|
||||
|
||||
in ()
|
||||
|
||||
|
|
@ -633,6 +650,10 @@ let /* Booleans */
|
|||
; if HAS_NIL_SYMBOL
|
||||
then stdval("nil", nil_val())
|
||||
|
||||
/* Identity function */
|
||||
; STD_LIB_ID_FUNCTION := fun_val(tape_pos(), nil)
|
||||
; app(OPCODE_RET, 1, "")
|
||||
|
||||
/* Useful standard functions */
|
||||
; stdfun("display")
|
||||
; app(OPCODE_TOSTR, 0, "")
|
||||
|
|
@ -730,7 +751,6 @@ let /* Booleans */
|
|||
in rec(insns.first, 0)
|
||||
end
|
||||
|
||||
|
||||
function set_tree_positions ( ast: sexp_ast
|
||||
, pos_l: int
|
||||
, pos_r: int ) =
|
||||
|
|
@ -742,17 +762,178 @@ let /* Booleans */
|
|||
then ( set_tree_positions( ast.val_cdr, pos_l, pos_r)
|
||||
; set_tree_positions( ast.val_car, pos_l, pos_r) ))
|
||||
|
||||
function compile_define_syntax (ast: sexp_ast): vm_insn_list =
|
||||
let var syntax_name := ast.val_cdr.val_car.val_s
|
||||
var variables := ast.val_cdr.val_cdr.val_car.val_cdr.val_car
|
||||
var rules := ast.val_cdr.val_cdr.val_car.val_cdr.val_cdr
|
||||
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)
|
||||
|
||||
var check_1 := ( ast.val_cdr.val_cdr.val_cdr.typ = type_nil )
|
||||
var check_2 := ( ast.val_cdr.val_cdr.val_car.val_car.typ = type_symbol
|
||||
& ast.val_cdr.val_cdr.val_car.val_car.val_s = "define-syntax")
|
||||
/* TODO */
|
||||
in ( compile_error("define-syntax not implemented!", ast)
|
||||
; list(nil) )
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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"
|
||||
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 */
|
||||
else if ast.val_car <> nil & ast.val_car.val_s = "begin"
|
||||
then let var insns := vm_insn_list { first = nil, last = nil }
|
||||
|
|
@ -1357,7 +1542,7 @@ let /* Booleans */
|
|||
; print(": ")
|
||||
; print(insn_to_string(tape[ip]))
|
||||
; 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")
|
||||
; ip := -1
|
||||
end
|
||||
|
|
@ -1393,12 +1578,14 @@ let /* Booleans */
|
|||
\ (display (cdr y)) (newline) \
|
||||
\ (set! x 10) \
|
||||
\ (display x) (newline) \
|
||||
|
||||
\ (define-syntax and \
|
||||
\ (syntax-rules ()\
|
||||
\ ((and) #t)\
|
||||
\ ((and test) test)\
|
||||
\ ((and test1 test2 ...)\
|
||||
\ (if test1 (and test2 ...) #f))))\
|
||||
|
||||
\ (display (and #t #t)) (newline) \
|
||||
\ (display (and #f #t)) (newline) \
|
||||
\ (display (and #f #f)) (newline) \
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user