/usr/share/r6rs/nanopass/language-node-counter.ss is in r6rs-nanopass-dev 1.9+git20160429.g1f7e80b-1build1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 | ;;; Copyright (c) 2000-2015 Andrew W. Keep
;;; See the accompanying file Copyright for details
(library (nanopass language-node-counter)
(export define-language-node-counter)
(import (rnrs) (nanopass records) (nanopass helpers))
(define-syntax define-language-node-counter
(lambda (x)
(define make-ntspec-counter-assoc
(lambda (tid)
(lambda (ntspec)
(cons ntspec (construct-unique-id tid "count-" (ntspec-name ntspec))))))
(syntax-case x ()
[(_ name lang)
(and (identifier? #'name) (identifier? #'lang))
(lambda (r)
(let ([l-pair (r #'lang)])
(unless l-pair (syntax-violation 'define-language-node-counter (format "unknown language ~s" (datum lang)) #'name x))
(let ([l (car l-pair)])
(let ([ntspecs (language-ntspecs l)] [tspecs (language-tspecs l)])
(let ([counter-names (map (make-ntspec-counter-assoc #'name) ntspecs)])
(define lookup-counter
(lambda (ntspec)
(cond
[(assq ntspec counter-names) => cdr]
[else (syntax-violation 'define-language-node-counter
(format "unexpected nonterminal ~s in language ~s"
(syntax->datum (ntspec-name ntspec)) (datum lang))
#'name x)])))
(define build-counter-proc
(lambda (proc-name l)
(lambda (ntspec)
(let loop ([alt* (ntspec-alts ntspec)] [term* '()] [nonterm* '()] [pair* '()])
(if (null? alt*)
#`(lambda (x)
(cond
#,@term*
#,@pair*
#,@nonterm*
[else (errorf who "unrecognized term ~s" x)]))
(let ([alt (car alt*)] [alt* (cdr alt*)])
(cond
[(terminal-alt? alt)
(loop alt*
(cons #`[(#,(tspec-pred (terminal-alt-tspec alt)) x) 1] term*)
nonterm* pair*)]
[(nonterminal-alt? alt)
(let ([ntspec (nonterminal-alt-ntspec alt)])
(loop alt* term*
(cons #`[(#,(ntspec-all-pred ntspec) x)
(#,(lookup-counter ntspec) x)]
nonterm*)
pair*))]
[(pair-alt? alt)
(let inner-loop ([fld* (pair-alt-field-names alt)]
[lvl* (pair-alt-field-levels alt)]
[maybe?* (pair-alt-field-maybes alt)]
[acc* (pair-alt-accessors alt)]
[rec* '()])
(if (null? fld*)
(loop alt* term* nonterm*
(cons #`[(#,(pair-alt-pred alt) x) (+ 1 #,@rec*)] pair*))
(inner-loop (cdr fld*) (cdr lvl*) (cdr maybe?*) (cdr acc*)
(cons
(let ([fld (car fld*)] [maybe? (car maybe?*)] [acc (car acc*)])
(let ([spec (find-spec fld l)])
(if (ntspec? spec)
#`(let ([x (#,acc x)])
#,(let loop ([lvl (car lvl*)] [outer-most? #t])
(if (fx=? lvl 0)
(if maybe?
(if outer-most?
#`(if x (#,(lookup-counter spec) x) 0)
#`(+ a (if x (#,(lookup-counter spec) x) 0)))
(if outer-most?
#`(#,(lookup-counter spec) x)
#`(+ a (#,(lookup-counter spec) x))))
(if outer-most?
#`(fold-left
(lambda (a x) #,(loop (- lvl 1) #f))
0 x)
#`(fold-left
(lambda (a x) #,(loop (- lvl 1) #f))
a x)))))
0)))
rec*))))]
[else (syntax-violation 'define-language-node-counter
(format "unrecognized alt ~s building language node counter" (syntax->datum (alt-syn alt)))
proc-name x)])))))))
(with-syntax ([(ntspec? ...) (map ntspec-pred ntspecs)]
[(proc-name ...) (map cdr counter-names)]
[(tspec? ...) (map tspec-pred tspecs)]
[(proc ...) (map (build-counter-proc #'name l) ntspecs)])
#'(define-who name
(lambda (x)
(define proc-name proc) ...
(cond
[(ntspec? x) (proc-name x)] ...
[(tspec? x) 1] ...
[else (errorf who "unrecognized language record ~s" x)])))))))))]))))
|