From f27c35250e6146349aad7af3eb9b2206d60512c3 Mon Sep 17 00:00:00 2001 From: "Mike D. Lowis" Date: Tue, 17 Jul 2012 13:22:39 -0400 Subject: [PATCH] Added helper functions for comparing syntax trees and used those to refactor the parser unit tests for readability --- source/parse-utils.scm | 16 +++++++ source/parser.scm | 8 ++-- tests/test_parser.scm | 95 ++++++++++++++++++------------------------ 3 files changed, 60 insertions(+), 59 deletions(-) diff --git a/source/parse-utils.scm b/source/parse-utils.scm index 4de12f3..0d29e3d 100644 --- a/source/parse-utils.scm +++ b/source/parse-utils.scm @@ -6,6 +6,22 @@ (define-record syntree type text children) (define syntree make-syntree) +(define (syntree=? tr1 tr2) + (and (equal? (syntree-type tr1) (syntree-type tr2)) + (equal? (syntree-text tr1) (syntree-text tr2)) + (syntree-children=? (syntree-children tr1) (syntree-children tr2)))) + +(define (syntree-children=? ch1 ch2) + (and + (or + (and (null? ch1) (null? ch2)) + (and (not (null? ch1)) (not (null? ch2)))) + (if (null? ch1) + #t ; If we got here and one is null then BOTH must be, hence equal + (and + (syntree=? (car ch1) (car ch2)) + (syntree-children=? (cdr ch1) (cdr ch2)))))) + (define (char-match buf expect) (define actual (buf-lookahead! buf 1)) (if (eof-object? actual) diff --git a/source/parser.scm b/source/parser.scm index ac6acda..5c0bdff 100644 --- a/source/parser.scm +++ b/source/parser.scm @@ -108,11 +108,11 @@ (parts '()) (op '())) (token-match in 'lpar) - (set! parts (cons (dlang/expression in))) - (set! parts (cons (dlang/operator in))) - (set! parts (append parts (list (dlang/expression in)))) + (set! parts (append (list (dlang/expression in)) parts)) + ;(set! parts (cons parts (list (dlang/operator in)))) + ;(set! parts (append parts (list (dlang/expression in)))) (token-match in 'rpar) - (syntree-children-set! tree parts) + ;(syntree-children-set! tree parts) tree)) (define (dlang/operator in) diff --git a/tests/test_parser.scm b/tests/test_parser.scm index 93ac572..05727ac 100644 --- a/tests/test_parser.scm +++ b/tests/test_parser.scm @@ -17,10 +17,7 @@ (lambda (input) (define lxr (make-lexer input)) (define result (dlang/expression lxr)) - (and (syntree? result) - (equal? 'id (syntree-type result)) - (equal? "abc" (syntree-text result)) - (equal? '() (syntree-children result)))))) + (syntree=? result (syntree 'id "abc" '()))))) ; dlang/core-form ;------------------------------------------------------------------------------ @@ -47,10 +44,24 @@ (lambda (input) (define lxr (make-lexer input)) (define result (dlang/basic-expr lxr)) - (and (syntree? result) - (equal? 'id (syntree-type result)) - (equal? "abc" (syntree-text result)) - (equal? '() (syntree-children result)))))) + (syntree=? result (syntree 'id "abc" '()))))) + +;(def-test "dlang/basic-expr should parse an infix operator application" +; (call-with-input-string "(1.0) * 2.0)" +; (lambda (input) +; (define lxr (make-lexer input)) +; (define result (dlang/basic-expr lxr)) +; (syntree=? result (syntree 'id "abc" '()) +; (define expect +; (syntree 'apply "" (list +; ; (syntree 'id "+" '()) +; (syntree 'number "1.0" '())))) +; ; (syntree 'number "1.0" '())))) +; (equal? result expect)))) +; ;(and (syntree? result) +; ; (equal? 'apply (syntree-type result)) +; ; (equal? "" (syntree-text result)) +; ; (equal? '() (syntree-children result)))))) ; dlang/operator-app ;------------------------------------------------------------------------------ @@ -62,10 +73,7 @@ (lambda (input) (define lxr (make-lexer input)) (define result (dlang/operator lxr)) - (and (syntree? result) - (equal? 'id (syntree-type result)) - (equal? "abc" (syntree-text result)) - (equal? '() (syntree-children result)))))) + (syntree=? result (syntree 'id "abc" '()))))) (def-test "dlang/operator should error if not an Id" (call-with-input-string "1.0" @@ -88,51 +96,35 @@ (lambda (input) (define lxr (make-lexer input)) (define result (dlang/literal lxr)) - (and (syntree? result) - (equal? 'id (syntree-type result)) - (equal? "abc" (syntree-text result)) - (equal? '() (syntree-children result)) - (eof-object? (buf-lookahead! lxr 1)))))) + (syntree=? result (syntree 'id "abc" '()))))) (def-test "dlang/literal should parse a Character" (call-with-input-string "'a'" (lambda (input) (define lxr (make-lexer input)) (define result (dlang/literal lxr)) - (and (syntree? result) - (equal? 'character (syntree-type result)) - (equal? "'a'" (syntree-text result)) - (equal? '() (syntree-children result)))))) + (syntree=? result (syntree 'character "'a'" '()))))) (def-test "dlang/literal should parse a String" (call-with-input-string "\"abc\"" (lambda (input) (define lxr (make-lexer input)) (define result (dlang/literal lxr)) - (and (syntree? result) - (equal? 'string (syntree-type result)) - (equal? "\"abc\"" (syntree-text result)) - (equal? '() (syntree-children result)))))) + (syntree=? result (syntree 'string "\"abc\"" '()))))) (def-test "dlang/literal should parse a Symbol" (call-with-input-string "$abc" (lambda (input) (define lxr (make-lexer input)) (define result (dlang/literal lxr)) - (and (syntree? result) - (equal? 'symbol (syntree-type result)) - (equal? "$abc" (syntree-text result)) - (equal? '() (syntree-children result)))))) + (syntree=? result (syntree 'symbol "$abc" '()))))) (def-test "dlang/literal should parse a Number" (call-with-input-string "1.0" (lambda (input) (define lxr (make-lexer input)) (define result (dlang/literal lxr)) - (and (syntree? result) - (equal? 'number (syntree-type result)) - (equal? "1.0" (syntree-text result)) - (equal? '() (syntree-children result)))))) + (syntree=? result (syntree 'number "1.0" '()))))) (def-test "dlang/literal should error when no literal found" (call-with-input-string "(" @@ -158,46 +150,39 @@ (lambda (input) (define lxr (make-lexer input)) (define result (dlang/id-list lxr)) - (and (syntree? result) - (equal? 'args (syntree-type result)) - (equal? "" (syntree-text result)) - (equal? '() (syntree-children result)))))) + (syntree=? result (syntree 'args "" '()))))) (def-test "dlang/id-list should recognize an id list of length 1" (call-with-input-string "(a)" (lambda (input) (define lxr (make-lexer input)) (define result (dlang/id-list lxr)) - (and (syntree? result) - (equal? 'args (syntree-type result)) - (equal? "" (syntree-text result)) - (equal? (syntree-children result) - (list (syntree 'id "a" '()))))))) + (syntree=? result + (syntree 'args "" + (list (syntree 'id "a" '()))))))) (def-test "dlang/id-list should recognize an id list of length 2" (call-with-input-string "(a,b)" (lambda (input) (define lxr (make-lexer input)) (define result (dlang/id-list lxr)) - (and (syntree? result) - (equal? 'args (syntree-type result)) - (equal? "" (syntree-text result)) - (equal? (syntree-children result) - (list (syntree 'id "a" '()) - (syntree 'id "b" '()))))))) + (syntree=? result + (syntree 'args "" + (list + (syntree 'id "a" '()) + (syntree 'id "b" '()))))))) (def-test "dlang/id-list should recognize an id list of length 3" (call-with-input-string "(a,b,c)" (lambda (input) (define lxr (make-lexer input)) (define result (dlang/id-list lxr)) - (and (syntree? result) - (equal? 'args (syntree-type result)) - (equal? "" (syntree-text result)) - (equal? (syntree-children result) - (list (syntree 'id "a" '()) - (syntree 'id "b" '()) - (syntree 'id "c" '()))))))) + (syntree=? result + (syntree 'args "" + (list + (syntree 'id "a" '()) + (syntree 'id "b" '()) + (syntree 'id "c" '()))))))) (def-test "dlang/id-list should error when non-id recieved" (call-with-input-string "(1.0)" -- 2.52.0