Implemented quasiquote.
This commit is contained in:
parent
b278001eeb
commit
4029ce9586
89
example.scm
89
example.scm
|
|
@ -3,7 +3,6 @@
|
|||
|
||||
; Lists
|
||||
|
||||
;
|
||||
(define (foldl f i l)
|
||||
(if (null? l)
|
||||
i
|
||||
|
|
@ -14,6 +13,7 @@
|
|||
i
|
||||
(f (car l) (foldr f i (cdr l)))))
|
||||
|
||||
|
||||
(define (map f l)
|
||||
(if (null? l)
|
||||
'()
|
||||
|
|
@ -25,6 +25,8 @@
|
|||
(define (reverse 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
|
||||
(lambda (x k)
|
||||
|
|
@ -73,6 +75,34 @@
|
|||
(display y) (newline)
|
||||
(display (car 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!
|
||||
|
||||
|
|
@ -117,6 +147,34 @@
|
|||
(display (reverse '(1 2 3 4 5)))
|
||||
(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
|
||||
|
||||
(newline)
|
||||
|
|
@ -131,37 +189,10 @@
|
|||
(display (cdr (string->datum "(display 2)")))
|
||||
(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
|
||||
|
||||
|
||||
|
||||
(exit)
|
||||
|
||||
(define-syntax and
|
||||
(syntax-rules ()
|
||||
|
|
|
|||
209
tigerscheme.tig
209
tigerscheme.tig
|
|
@ -7,10 +7,11 @@ let /* Booleans */
|
|||
|
||||
/* 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 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
|
||||
|
||||
|
|
@ -327,24 +328,31 @@ let /* Booleans */
|
|||
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_tick (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): int =
|
||||
function is_symbol (index: int): bool =
|
||||
let var ascii := ord(substring(str, index, 1))
|
||||
in not ( ascii = 9
|
||||
| ascii = 10
|
||||
| ascii = 32
|
||||
| ascii = 40
|
||||
| ascii = 41
|
||||
| ascii = ord("\"")
|
||||
| ascii = ord("'")
|
||||
| ascii = ord(";") )
|
||||
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 =
|
||||
|
|
@ -369,12 +377,15 @@ let /* Booleans */
|
|||
; val
|
||||
end
|
||||
|
||||
function sexp_quote (datum: sexp_ast, pos_l: pos, pos_r: pos): sexp_ast =
|
||||
sexp_pair( sexp_atom( "quote", pos_l, pos_r)
|
||||
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
|
||||
|
|
@ -425,20 +436,35 @@ let /* Booleans */
|
|||
( ignore_ws()
|
||||
; if is_symbol(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
|
||||
; sexp_atom( safe_substring(str, at_char(start_pos), index-1)
|
||||
, start_pos
|
||||
, new_pos(line_number, index - 1) )
|
||||
end
|
||||
|
||||
else if is_tick(index)
|
||||
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_quote( datum
|
||||
, start_pos
|
||||
, new_pos(line_number, index))
|
||||
|
||||
var exp := sexp_wrap( modifier
|
||||
, datum
|
||||
, start_pos
|
||||
, new_pos(line_number, index))
|
||||
|
||||
in exp
|
||||
end
|
||||
|
|
@ -527,7 +553,7 @@ let /* Booleans */
|
|||
, most_right )
|
||||
else sexp
|
||||
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) =
|
||||
let
|
||||
|
|
@ -749,9 +775,9 @@ let /* Booleans */
|
|||
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: 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)
|
||||
in tail_position(insns, return_now, pos_l, pos_r)
|
||||
in tail_position(insns, return_now, insn.pos_l, insn.pos_r)
|
||||
; insns
|
||||
end
|
||||
|
||||
|
|
@ -1018,15 +1044,21 @@ let /* Booleans */
|
|||
, base_env )
|
||||
|
||||
function env_seek_elem(env: vm_env, key: string): vm_env =
|
||||
let var head := env
|
||||
in while head <> nil
|
||||
let function valid_head (head: vm_env): bool =
|
||||
head <> 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
|
||||
; if head <> nil
|
||||
& head.typ <> type_nil
|
||||
then head
|
||||
; if valid_head(head)
|
||||
& head.val_car.val_car.val_s = key
|
||||
then head
|
||||
else nil
|
||||
end
|
||||
|
||||
|
|
@ -1316,6 +1348,78 @@ let /* Booleans */
|
|||
, 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 ( 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 =
|
||||
if ast = nil then nil
|
||||
|
|
@ -1329,7 +1433,7 @@ let /* Booleans */
|
|||
/* 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 )
|
||||
, can_tail_call)
|
||||
|
||||
/* If statements */
|
||||
else if ast.val_car <> nil
|
||||
|
|
@ -1389,9 +1493,23 @@ let /* Booleans */
|
|||
, arg3 = datum
|
||||
, pos_l = ast.pos_l
|
||||
, pos_r = ast.pos_r }
|
||||
, can_tail_call
|
||||
, ast.pos_l
|
||||
, 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 */
|
||||
|
|
@ -1444,6 +1562,7 @@ let /* Booleans */
|
|||
/* 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)
|
||||
|
|
@ -1453,10 +1572,17 @@ let /* Booleans */
|
|||
; print(value_to_string(fun))
|
||||
; print(" as macro\n")*/
|
||||
; if fun <> nil & fun.typ <> type_closure
|
||||
then compile_error("Attempting to use non-function as macro function.", ast)
|
||||
; 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)
|
||||
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 */
|
||||
|
|
@ -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 start_index := tape_append(tape, insns)
|
||||
in ()
|
||||
/*print("Parsed: ")
|
||||
; print(value_to_string(sexp))
|
||||
; print("\n") */
|
||||
; if DEBUG_PRINT_PARSED
|
||||
then ( print("Parsed: ")
|
||||
; print(value_to_string(sexp))
|
||||
; print("\n"))
|
||||
|
||||
; if DEBUG_PRINT_TAPE
|
||||
then ( print("Tape:\n")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user