diff --git a/beautiful-racket-ragg/br/ragg/codegen/codegen.rkt b/beautiful-racket-ragg/br/ragg/codegen/codegen.rkt index d5594a8..3ada6f9 100755 --- a/beautiful-racket-ragg/br/ragg/codegen/codegen.rkt +++ b/beautiful-racket-ragg/br/ragg/codegen/codegen.rkt @@ -172,8 +172,11 @@ (with-syntax ([(translated-clause ...) translated-clauses]) #`[name translated-clause ...]))])) - - +#| +MB: This function generates the input for the parse tree, +passing it to the two functions in "runtime.rkt". +|# +(require (only-in sugar/debug report report*)) ;; translates a single primitive rule clause. ;; A clause is a simple list of ids, lit, vals, and inferred-id elements. ;; The action taken depends on the pattern type. @@ -210,6 +213,7 @@ ;; whose head is the name of the inferred rule . We strip that out, ;; leaving the residue to be absorbed. [(inferred-id val reason) + (report* #'val #'reason) #'(syntax-case $X () [(inferred-rule-name . rest) (syntax->list #'rest)])] diff --git a/beautiful-racket-ragg/br/ragg/codegen/runtime.rkt b/beautiful-racket-ragg/br/ragg/codegen/runtime.rkt index d38b244..0665678 100755 --- a/beautiful-racket-ragg/br/ragg/codegen/runtime.rkt +++ b/beautiful-racket-ragg/br/ragg/codegen/runtime.rkt @@ -141,6 +141,10 @@ #f))) +#| +MB: The next three functions control the appearance of the generated parse tree. +|# + ;; We create a syntax using read-syntax; by definition, it should have the ;; original? property set to #t, which we then copy over to syntaxes constructed ;; with atomic-datum->syntax and rule-components->syntax. @@ -152,7 +156,7 @@ ;; Helper that does the ugly work in wrapping a datum into a syntax ;; with source location. (define (atomic-datum->syntax d start-pos end-pos) - (datum->syntax #f d (positions->srcloc start-pos end-pos) stx-with-original?-property)) + (syntax-property (datum->syntax #f d (positions->srcloc start-pos end-pos) stx-with-original?-property) 'foo 'atom)) @@ -161,10 +165,10 @@ ;; The location information of the rule spans that of its components. (define (rule-components->syntax rule-name/false #:srcloc [srcloc #f] . components) (define flattened-components (apply append components)) - (datum->syntax #f + (syntax-property (datum->syntax #f (apply append (list - (datum->syntax #f rule-name/false srcloc stx-with-original?-property)) + (syntax-property (datum->syntax #f rule-name/false srcloc stx-with-original?-property) 'foo 'rule-name)) components) srcloc - stx-with-original?-property)) + stx-with-original?-property) 'foo 'whole-rule)) diff --git a/beautiful-racket-ragg/br/ragg/test/test-baby-json.rkt b/beautiful-racket-ragg/br/ragg/test/test-baby-json.rkt index b9c97f9..d9847b5 100755 --- a/beautiful-racket-ragg/br/ragg/test/test-baby-json.rkt +++ b/beautiful-racket-ragg/br/ragg/test/test-baby-json.rkt @@ -14,8 +14,14 @@ (kvpair "message" ":" (json (string "'hello world'"))) "}"))) +(require sugar/debug) +(syntax-property (report (cadr (syntax->list (cadr (syntax->list (parse (list "{" + (token 'ID "message") + ":" + (token 'STRING "'hello world'") + "}"))))))) 'foo) -(check-equal? +#;(check-equal? (syntax->datum (parse "[[[{}]],[],[[{}]]]")) '(json (array #\[ (json (array #\[ (json (array #\[ (json (object #\{ #\})) #\])) #\])) #\, (json (array #\[ #\])) #\, (json (array #\[ (json (array #\[ (json (object #\{ #\})) #\])) #\])) #\])))