Jmaa/tiger-scheme
1
0
Fork 0
Code

Implemented quasiquote.

Browse Source
This commit is contained in:
Jon Michael Aanes 2018-12-21 20:37:57 +01:00
parent b278001eeb
commit 4029ce9586
2 changed files with 228 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
example.scm
View File

@ -3,7 +3,6 @@
; Lists ; Lists
;
(define (foldl f i l) (define (foldl f i l)
(if (null? l) (if (null? l)
i i
@ -14,6 +13,7 @@
i i
(f (car l) (foldr f i (cdr l))))) (f (car l) (foldr f i (cdr l)))))
(define (map f l) (define (map f l)
(if (null? l) (if (null? l)
'() '()
@ -25,6 +25,8 @@
(define (reverse l) (define (reverse l)
(foldl cons '() l)) (foldl cons '() l))
(define (append l1 l2)
(foldr cons l2 l1))
(define list-tail; Taken from https://people.csail.mit.edu/jaffer/r5rs/Pairs-and-lists.html (define list-tail; Taken from https://people.csail.mit.edu/jaffer/r5rs/Pairs-and-lists.html
(lambda (x k) (lambda (x k)
@ -73,6 +75,34 @@
(display y) (newline) (display y) (newline)
(display (car y)) (newline) (display (car y)) (newline)
(display (cdr y)) (newline) (display (cdr y)) (newline)
(display (append '(1 2 3) '(4 5 6))) (newline)
(display "\n* R5RS: Quotation and quasi-quotation *\n")
(display "Testing quotation!\n\tExpect: (1 2 3)\n\tGotten: ")
(define (x) (quote (1 2 3)))
(display (x))
(newline)
(display "Testing quotation!\n\tExpect: (1 2 3)\n\tGotten: ")
(define (x) '(1 2 3))
(display (x))
(newline)
(display "Testing quasi-notation basics!\n\tExpect: (1 2 3)\n\tGotten: ")
(define (x) `(1 2 3))
(display (x))
(newline)
(display "Testing quasi-notation!\n\tExpect: (1 a 2 a 3 a 4)\n\tGotten: ")
(define (x p) `(1 ,p 2 ,p 3 ,p 4))
(display (x 'a))
(newline)
(display "Testing quasi-notation advanced!\n\tExpect: (1 2 3 4 5)\n\tGotten: ")
(define (x p) `(1 ,@p 3))
(display (x '(2 3 4)))
(newline)
; Check set! ; Check set!
@ -117,6 +147,34 @@
(display (reverse '(1 2 3 4 5))) (display (reverse '(1 2 3 4 5)))
(newline) (newline)
(newline)
(display "* R5RS: Testing Eval system *")
(newline)
(display "Eval expression. Expect 6: ")
(display (eval '(* 2 (cdr '(2 . 3))) (scheme-report-environment 5)))
(newline)
(newline)
(display "* R5RS: Testing Macro system *")
(newline)
; Test define-syntax
(display "Test define-syntax:\n Expect: 4 ()\n Gotten: ")
(define-syntax const
(lambda (so)
`(lambda () ,(car (cdr so)))))
(define x (const 4))
(display (x))
(display " ")
(define x (const '()))
(display (x))
(display "\n")
; Test environment set ; Test environment set
(newline) (newline)
@ -131,37 +189,10 @@
(display (cdr (string->datum "(display 2)"))) (display (cdr (string->datum "(display 2)")))
(newline) (newline)
(newline)
(display "* Testing Eval system *")
(newline)
(display "Eval expression. Expect 6: ")
(display (eval '(* 2 (cdr '(2 . 3))) (scheme-report-environment 5)))
(newline)
(newline)
(display "* Testing Macro system *")
(newline)
; Test define-syntax
(display "Test define-syntax:\n Expect: 4 ()\n Gotten: ")
(define-syntax const
(lambda (so)
(cons 'lambda (cons '() (cdr so)))))
(define x (const 4))
(display (x))
(display " ")
(define x (const '()))
(display (x))
(display "\n")
; Test syntax-rules ; Test syntax-rules
(exit)
(define-syntax and (define-syntax and
(syntax-rules () (syntax-rules ()

209
tigerscheme.tig
View File

@ -7,10 +7,11 @@ let /* Booleans */
/* Settings */ /* Settings */
var IS_NIL_TRUTHY : bool := false var IS_NIL_TRUTHY : bool := false
var HAS_NIL_SYMBOL : bool := false var HAS_NIL_SYMBOL : bool := false
var DEBUG_PRINT_STACK : bool := false var DEBUG_PRINT_STACK : bool := false
var DEBUG_PRINT_TAPE : bool := false var DEBUG_PRINT_TAPE : bool := false
var DEBUG_PRINT_PARSED : bool := false
var TRIGGERED_EXIT : bool := false var TRIGGERED_EXIT : bool := false
@ -327,24 +328,31 @@ let /* Booleans */
function is_left_paren (index: int): bool = is_char("(", index) function is_left_paren (index: int): bool = is_char("(", index)
function is_right_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_comment_start (index: int): bool = is_char(";", index)
function is_tick (index: int): bool = is_char("'", index)
function is_goose_marks (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 = function is_ws (index: int): int =
let var ascii := ord(substring(str, index, 1)) let var ascii := ord(substring(str, index, 1))
in ascii = 32 | ascii = 9 | ascii = 10 in ascii = 32 | ascii = 9 | ascii = 10
end end
function is_symbol (index: int): int = function is_symbol (index: int): bool =
let var ascii := ord(substring(str, index, 1)) let var ascii := ord(substring(str, index, 1))
in not ( ascii = 9 in ord("0") <= ascii & ascii <= ord("9")
| ascii = 10 | ord("a") <= ascii & ascii <= ord("z")
| ascii = 32 | ord("A") <= ascii & ascii <= ord("Z")
| ascii = 40 | ascii = ord("!") | ascii = ord("$") | ascii = ord("%")
| ascii = 41 | 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 end
function sexp_nil (pos_l: pos, pos_r: pos): sexp_ast = function sexp_nil (pos_l: pos, pos_r: pos): sexp_ast =
@ -369,12 +377,15 @@ let /* Booleans */
; val ; val
end end
function sexp_quote (datum: sexp_ast, pos_l: pos, pos_r: pos): sexp_ast = function sexp_wrap (atom: string, datum: sexp_ast, pos_l: pos, pos_r: pos): sexp_ast =
sexp_pair( sexp_atom( "quote", pos_l, pos_r) sexp_pair( sexp_atom( atom, pos_l, pos_r)
, sexp_pair( datum, sexp_nil(pos_l, pos_r) , sexp_pair( datum, sexp_nil(pos_l, pos_r)
, pos_l, pos_r) , 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 function sexp_pair ( car: sexp_ast
, cdr: sexp_ast , cdr: sexp_ast
, pos_l: pos , pos_l: pos
@ -425,20 +436,35 @@ let /* Booleans */
( ignore_ws() ( ignore_ws()
; if is_symbol(index) ; if is_symbol(index)
then let var start_pos := new_pos(line_number, index) then let var start_pos := new_pos(line_number, index)
in while is_symbol(index) in while index < size(str) & is_symbol(index)
do index := index + 1 do index := index + 1
; sexp_atom( safe_substring(str, at_char(start_pos), index-1) ; sexp_atom( safe_substring(str, at_char(start_pos), index-1)
, start_pos , start_pos
, new_pos(line_number, index - 1) ) , new_pos(line_number, index - 1) )
end end
else if is_tick(index) else if is_quick_modifier(index)
then let var start_pos := new_pos(line_number, 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 var datum := ( index := index + 1
; if modifier = "unquote-splicing"
then index := index + 1
; parse_rec() ) ; parse_rec() )
var exp := sexp_quote( datum
, start_pos var exp := sexp_wrap( modifier
, new_pos(line_number, index)) , datum
, start_pos
, new_pos(line_number, index))
in exp in exp
end end
@ -527,7 +553,7 @@ let /* Booleans */
, most_right ) , most_right )
else sexp else sexp
end end
else (parse_error("Error: I don't even!"); nil)) else (parse_error("Found no way to progress parsing"); nil))
function parse_error(errmsg: string) = function parse_error(errmsg: string) =
let let
@ -749,9 +775,9 @@ let /* Booleans */
if return_now if return_now
then app_insn(prev_insns, OPCODE_RET, 1, "", pos_l, pos_r) then app_insn(prev_insns, OPCODE_RET, 1, "", pos_l, pos_r)
function tail_position_one (insn: vm_insn, return_now: bool, pos_l: pos, pos_r: pos): vm_insn_list = function tail_position_one (insn: vm_insn, return_now: bool): vm_insn_list =
let var insns := single_insn(insn) let var insns := single_insn(insn)
in tail_position(insns, return_now, pos_l, pos_r) in tail_position(insns, return_now, insn.pos_l, insn.pos_r)
; insns ; insns
end end
@ -1018,15 +1044,21 @@ let /* Booleans */
, base_env ) , base_env )
function env_seek_elem(env: vm_env, key: string): vm_env = function env_seek_elem(env: vm_env, key: string): vm_env =
let var head := env let function valid_head (head: vm_env): bool =
in while head <> nil head <> nil
& head.typ <> type_nil & head.typ <> type_nil
& head.val_car.val_car.val_s <> key /*& 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 do head := head.val_cdr
; if head <> nil ; if valid_head(head)
& head.typ <> type_nil & head.val_car.val_car.val_s = key
then head then head
else nil else nil
end end
@ -1316,6 +1348,78 @@ let /* Booleans */
, ast) , ast)
; list(nil)) ; 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 ( compile_error("TODO: Nested quasiquote", datum)
; 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 = function compile_rec (ast: sexp_ast, can_tail_call: int): vm_insn_list =
if ast = nil then nil if ast = nil then nil
@ -1329,7 +1433,7 @@ let /* Booleans */
/* Handle numbers and other constants */ /* Handle numbers and other constants */
else if ast.typ <> type_pair then else if ast.typ <> type_pair then
tail_position_one( atom_to_insn(ast, ast.pos_l, ast.pos_r) tail_position_one( atom_to_insn(ast, ast.pos_l, ast.pos_r)
, can_tail_call, ast.pos_l, ast.pos_r ) , can_tail_call)
/* If statements */ /* If statements */
else if ast.val_car <> nil else if ast.val_car <> nil
@ -1389,9 +1493,23 @@ let /* Booleans */
, arg3 = datum , arg3 = datum
, pos_l = ast.pos_l , pos_l = ast.pos_l
, pos_r = ast.pos_r } , pos_r = ast.pos_r }
, can_tail_call , can_tail_call)
, ast.pos_l end
, ast.pos_r)
/* 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 end
/* Set statements */ /* Set statements */
@ -1444,6 +1562,7 @@ let /* Booleans */
/* Macro applications */ /* Macro applications */
else if ast.val_car <> nil else if ast.val_car <> nil
& ast.val_car.typ = type_symbol & ast.val_car.typ = type_symbol
& ast.val_car.val_s <> ""
& env_seek_elem(env_macro, ast.val_car.val_s) <> nil & env_seek_elem(env_macro, ast.val_car.val_s) <> nil
then let var stack := stack_new() then let var stack := stack_new()
var env_elem := env_seek_elem(env_macro, ast.val_car.val_s) var env_elem := env_seek_elem(env_macro, ast.val_car.val_s)
@ -1453,10 +1572,17 @@ let /* Booleans */
; print(value_to_string(fun)) ; print(value_to_string(fun))
; print(" as macro\n")*/ ; print(" as macro\n")*/
; if fun <> nil & fun.typ <> type_closure ; if fun <> nil & fun.typ <> type_closure
then compile_error("Attempting to use non-function as macro function.", ast) then ( compile_error(concat5( "Attempting to use non-function "
; vm_run(macro_tape, fun.val_i, stack, fun.val_car, "", env_global) , value_to_string(fun)
/* TODO: Assert that there is something on the stack */ , " refered to as \""
; compile_rec(stack_pop(stack), can_tail_call) , 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 end
/* Call expressions */ /* Call expressions */
@ -1947,9 +2073,10 @@ in print("Ready for the scheming Tiger?\n")
var insns := compile_to_vm(sexp_compile, env_macro, tape, env_global) var insns := compile_to_vm(sexp_compile, env_macro, tape, env_global)
var start_index := tape_append(tape, insns) var start_index := tape_append(tape, insns)
in () in ()
/*print("Parsed: ") ; if DEBUG_PRINT_PARSED
; print(value_to_string(sexp)) then ( print("Parsed: ")
; print("\n") */ ; print(value_to_string(sexp))
; print("\n"))
; if DEBUG_PRINT_TAPE ; if DEBUG_PRINT_TAPE
then ( print("Tape:\n") then ( print("Tape:\n")