#lang s-exp syntax/module-reader (planet wrturtle/pyret/bsl/language) #:read my-read #:read-syntax my-read-syntax #:whole-body-readers? #t #:language-info '#((planet wrturtle/pyret/bsl/lang/lang-info) get-info #f) #:info (lambda (key defval default) (case key [(color-lexer) (dynamic-require '(planet wrturtle/pyret/bsl/tool/syntax-color) 'get-syntax-token)] [else (default key defval)])) (require "../lexer.rkt") (require "../parser.rkt") (require racket/contract/base) (define (stx->orig-stx stx) (define (datum? o) (or (symbol? o) (string? o) (number? o) (boolean? o))) (let ([se (syntax-e stx)]) (cond [((listof syntax?) se) (datum->syntax stx (map stx->orig-stx se) stx)] [(datum? se) (begin (define p (open-input-string (if (string? se) (format "~e" se) (format "~a" se)))) (port-count-lines! p) (define source (syntax-source stx)) (define line (syntax-line stx)) (define col (syntax-column stx)) (define off (syntax-position stx)) (define span (syntax-span stx)) (set-port-next-location! p line col off) (read-syntax source p))] [else stx]))) (define (my-read in) (syntax->datum (car (my-read-syntax #f in)))) (define (my-read-syntax src in) (let ([srcname (if (string? src) src (if (symbol? src) src (if (path? src) src (begin (printf "using false as source name\n") #f))))]) (parameterize ([lexer-source-name srcname] [parser-source-name srcname] [nal-state (newline-adding-lexer-state #f)]) (map stx->orig-stx (program-parser (lambda () (newline-adding-lexer in)))))))