diff --git a/example.scm b/example.scm index c8749a3..5828518 100644 --- a/example.scm +++ b/example.scm @@ -1,4 +1,6 @@ + + ;;; Standard lib, in scheme ; Lists @@ -28,6 +30,7 @@ (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) (if (zero? k) @@ -48,6 +51,42 @@ (define (odd? x) (= (mod x 2) 1)) (define (even? x) (= (mod x 2) 0)) +;;;;;;;; Testing stuff ;;;;;;;;;; + + +; Test some compilation stuff + +(define f (lambda (x) ((lambda (y) (+ y 2)) (car x)))) + +(define g (lambda (x) (if ((lambda (y) (= y 2)) (car x)) + y + 'fuck))) + +(define fac_fucked + ( (lambda (f) (lambda (v) (f f v))) + (lambda (f v) + (if (= v 0) + 1 + (* v (f f (+ v -1))))))) + +(display "Recursive combinator used on factorial.\n\tExpect: 120\n\tGotten: ") +(display (fac_fucked 5)) +(newline) + +; Test that function arguments are in correct order + +(define (test-arg-order a b c) + (begin (display a) + (display " ") + (display b) + (display " ") + (display c) + (newline))) + +(display "Testing that argument order is correct:\n\tExpect: 1 2 3\n\tGotten: ") +(test-arg-order 1 2 3) +(display "\n") + ; Test string (display "Hello World") (newline) @@ -78,6 +117,7 @@ (display y) (newline) (display (car y)) (newline) (display (cdr y)) (newline) + (display (append '(1 2 3) '(4 5 6))) (newline) ; Test system @@ -142,6 +182,11 @@ (display (f 1 5)) (newline) +(display "Testing quasi-notation advanced!\n\tExpect: ((1 2) . 3)\n\tGotten: ") +(define (f) (cons `(1 2) 3)) +(display (f)) +(newline) + ; Check set! (set! x 10) @@ -290,8 +335,22 @@ (display (x)) (display "\n") +(display "Test defining let using macroes:\n Expect: 23 82 105\n Gotten: ") -(display "\n* R5RS: Lexical convention *\n") +(define-syntax let + (lambda (vo) + `( (lambda ,(map car (cadr vo)) ,(caddr vo)) + ,@(map cadr (cadr vo))))) + +(let ((a 23) + (b 82)) + (begin (display a) + (display " ") + (display b) + (display " ") + (display (+ a b)))) + +(display "\n* R5RS: Lexical conventions *\n") (define a-variable 20) (if #f (begin @@ -318,22 +377,107 @@ ; Test syntax-rules -(newline) -(display "* Testing syntax-rules (move to macro once implemented) *") -(newline) +(header "Testing syntax-rules (move to macro once implemented)") -(display "Attempting to define true using syntax rules.\n\tExpect: #t #f\n\tGotten: ") +(define equal? eqv?) + +(define construct-pattern-predicate + (lambda (name pat) + (if (if (symbol? pat) #t (number? pat)) + `(equal? ,name ',pat) + (if (null? pat) + `(null? ,name) + (if (pair? pat) + `(if (pair? ,name) + (if ,(construct-pattern-predicate `(car ,name) (car pat)) + ,(construct-pattern-predicate `(cdr ,name) (cdr pat)) + #f) + #f) + 'fuck ))))) + +(define syntax-rules-rec + (lambda (macro-name var-name rules) + (if (null? rules) + 'doublefuck + (let ((pattern (caar rules)) + (result (cadar rules))) + (if (eqv? macro-name (car pattern)) + `(if ,(construct-pattern-predicate var-name pattern) + ',result + ,(syntax-rules-rec macro-name var-name (cdr rules))) + + (begin (display "Incorrect usage of syntax-rules-rec: Each rule must have same first symbol.") + (display "\n\tFirst had ") + (display macro-name) + (display "\n\tBut one of them had ") + (display (car pattern)) + (newline))))))) + + + +(define-syntax syntax-rules + (lambda (vo) + (let ((literals (cadr vo)) + (rules (cddr vo)) + (name (car (caaddr vo)))) + + `(lambda (vo2) + ,( syntax-rules-rec name 'vo2 rules)) + ))) + +; Define true + +(syntax-rules () + ((name ...) ...)) (define-syntax true (syntax-rules () ((true) #t))) -(display (true)) -(display " ") -(display (not (true))) +(test "Attempting to define true using syntax rules." + `( + ( #t . ,(true)) + ( #f . ,(not (true))) + )) + +; -(display "Attempting to define and using syntax rules.\n\tExpect: #t #f #f #f\n\tGotten: ") +; Below should produce an error: +;(define-syntax bad-rule + ;(syntax-rules () + ;((bad-rule-1) #t) + ;((bad-rule-2) #f))) + +(define-syntax bool + (syntax-rules () + ((bool) #t) + ((bool 0) #f) + ((bool 1) #t) + )) + +(test "Attempting to define bool ? using syntax rules." + `( + ( #t . ,(bool)) + ( #f . ,(bool 0)) + ( #t . ,(bool 1)) + )) + +(define-syntax derp + (syntax-rules () + ((derp) 1) + ((derp two) (+ (derp) (derp))) + )) + +(test "Defining weird macroes using syntax-rules." + `( + ( 1 . ,(derp)) + ( 2 . ,(derp two)) + )) + +;;;;; ; + +(exit) (define-syntax and (syntax-rules () @@ -342,10 +486,21 @@ ((and test1 test2 ...) (if test1 (and test2 ...) #f)))) -(display (and #t #t)) (display " ") -(display (and #f #t)) (display " ") -(display (and #f #f)) (display " ") -(display (and #t #f)) (newline) +(test "Attempting to define and using syntax rules." + `( + (#t . ,(and)) + (#f . ,(and #f)) + (#t . ,(and #t)) + (#f . ,(and #f #f)) + (#f . ,(and #t #f)) + (#f . ,(and #f #t)) + (#t . ,(and #t #t)) + (#f . ,(and #t #f #t)) + (#f . ,(and #f #f #f)) + (#t . ,(and #t #t #t)) + (#f . ,(and #f #t #f #f #f #f)) + (#t . ,(and #t #t #t #t #t #t)) + )) ; TODO: Use syntax-rules to implement let and or. diff --git a/tigerscheme.tig b/tigerscheme.tig index 579160c..b9970cd 100644 --- a/tigerscheme.tig +++ b/tigerscheme.tig @@ -1024,11 +1024,12 @@ let /* Booleans */ then app_insn(prev_insns, OPCODE_RET, 1, "", pos_l, pos_r) 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, insn.pos_l, insn.pos_r) - ; insns - end - + if insn = nil + then nil + else let var insns := single_insn(insn) + in tail_position(insns, return_now, insn.pos_l, insn.pos_r) + ; insns + end var ENV_EMPTY : vm_env := nil_val() var ENV_STD : vm_env := ENV_EMPTY @@ -1108,10 +1109,53 @@ let /* Booleans */ ; app(OPCODE_CONS, 0, "") ; app(OPCODE_RET, 1, "") + ; stdfun("caaaar") + ; app(OPCODE_CAR, 0, "") + ; stdfun("caaar") + ; app(OPCODE_CAR, 0, "") + ; stdfun("caar") + ; app(OPCODE_CAR, 0, "") ; stdfun("car") ; app(OPCODE_CAR, 0, "") ; app(OPCODE_RET, 1, "") + ; stdfun("cadddr") + ; app(OPCODE_CDR, 0, "") + ; stdfun("caddr") + ; app(OPCODE_CDR, 0, "") + ; stdfun("cadr") + ; app(OPCODE_CDR, 0, "") + ; app(OPCODE_CAR, 0, "") + ; app(OPCODE_RET, 1, "") + + ; stdfun("caadar") + ; app(OPCODE_CAR, 0, "") + ; app(OPCODE_DGOTO, 2, "") + ; stdfun("caaddr") + ; app(OPCODE_CDR, 0, "") + ; stdfun("caadr") + ; app(OPCODE_CDR, 0, "") + ; app(OPCODE_CAR, 0, "") + ; app(OPCODE_CAR, 0, "") + ; app(OPCODE_RET, 1, "") + + ; stdfun("cadadr") + ; app(OPCODE_CDR, 0, "") + ; app(OPCODE_DGOTO, 2, "") + ; stdfun("cadaar") + ; app(OPCODE_CAR, 0, "") + ; stdfun("cadar") + ; app(OPCODE_CAR, 0, "") + ; app(OPCODE_CDR, 0, "") + ; app(OPCODE_CAR, 0, "") + ; app(OPCODE_RET, 1, "") + + ; stdfun("cddddr") + ; app(OPCODE_CDR, 0, "") + ; stdfun("cdddr") + ; app(OPCODE_CDR, 0, "") + ; stdfun("cddr") + ; app(OPCODE_CDR, 0, "") ; stdfun("cdr") ; app(OPCODE_CDR, 0, "") ; app(OPCODE_RET, 1, "") @@ -1272,9 +1316,24 @@ let /* Booleans */ ; app2(OPCODE_PUSH, VALUE_UNSPECIFIED) ; app(OPCODE_RET, 1, "") + ; stdfun("debug-show-env") + ; app(OPCODE_DEBUG, 3, "") + ; app2(OPCODE_PUSH, VALUE_UNSPECIFIED) + ; app(OPCODE_RET, 1, "") + + ; stdfun("exit") ; app(OPCODE_EXIT, true, "") + /* Should never be called as function! */ + ; stdfun("quote") + ; stdfun("quasiquote") + ; stdfun("unquote") + ; stdfun("unquote-splicing") + ; app2(OPCODE_PUSH, string_val("Error! This is a macro and cannot be called as an actual function!\n")) + ; app(OPCODE_OUTPUT, 0, "") + ; app(OPCODE_EXIT, true, "") + /* Misc??? */ ; stdfun("symbol?") ; app(OPCODE_TYPEOF, 0, "") @@ -1401,6 +1460,12 @@ let /* Booleans */ | symbol = "quasiquote" | symbol = "unquote" | symbol = "unquote-splicing" | symbol = "define" | symbol = "define-syntax" + function is_not_variable (symbol: string): bool = + symbol = "if" | symbol = "let" | symbol = "unquote" + | symbol = "lambda" | symbol = "quote" | symbol = "quasiquote" + | symbol = "unquote" | symbol = "unquote-splicing" + | symbol = "" + /**** Compilation ****/ function compile_to_vm ( ast: sexp_ast @@ -1428,11 +1493,21 @@ let /* Booleans */ else if expected_type <> 0 & sym.typ <> type_symbol & sym.typ <> expected_type - then ( print(concat5( "Error in atom_to_list: Expected " - , type_id_to_name(expected_type) - , " but got " - , value_to_string(sym) - , "!\n")) + then ( compile_error( concat5("Error in atom_to_list: Expected " + , type_id_to_name(expected_type) + , " but got " + , value_to_string(sym) + , "!\n") + , sym) + ; nil ) + + else if is_symbol(sym) & is_not_variable(sym.val_s) + then ( compile_error(concat5( "Error in atom_to_list: Impossible to load variable " + , sym.val_s + , " because it is not a variable!\n" + , "" + , "") + , sym) ; nil ) else if is_symbol(sym) @@ -1455,7 +1530,9 @@ let /* Booleans */ 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) + in if insns = nil + then 0 + else rec(insns.first, 0) end function set_tree_positions ( ast: sexp_ast @@ -1784,6 +1861,16 @@ let /* Booleans */ ( compile_error("Attempting to compile free-standing (). This is not allowed.\n Must use \"'()\", if nil value is wanted.", ast) ; nil ) + /* Throw error if encountering unquote or + * unquote-splicing outside of quasiquote */ + else if ast.typ = type_symbol + & (ast.val_s = "unquote" | ast.val_s = "unquote-splicing") + then ( compile_error(concat5( "Attempting to use \"" + , ast.val_s + , "\" outside of a quasiquote! It may be some misplaced brackets." + , "", ""), 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, expected_type) @@ -2467,6 +2554,8 @@ let /* Booleans */ then DEBUG_PRINT_TAPE := val_b else if tape[ip].arg1 = 2 then DEBUG_PRINT_STACK := val_b + else if tape[ip].arg1 = 3 + then DEBUG_SHOW_FULL_ENVIRONMENT := val_b else run_error("Attempting to use unknown debug option!") ; ip := ip + 1