Jack,
There exists a language that wasn't initially designed with racket in mind, but
could easily be a racket #lang. To interop with code already written in this
language, I wanted an easy way to run files that don't have the #lang line.
I had a very similar case when I had to create a command-line program
that runs files written in some DSL without #lang in them. Below is what
I came up with. The prefix-input-port and require-input-port routines
came from Matthew Flatt: he wrote them at my request in this newsgroup a
couple years ago. Thank you again Matthew, I still use them.
Best regards,
Dmitry
#lang racket
(require syntax/modread
errortrace
errortrace/errortrace-key)
;; prefix-input-port : bytes input-port -> input-port
;; Directs position requests to the given port after the
;; prefix is read.
;; Closes the given input port when the result port is closed.
(define (prefix-input-port prefix base-p)
(define-values (prefix-i prefix-o) (make-pipe))
(write-bytes prefix prefix-o)
(close-output-port prefix-o)
(define (prefix-done?)
(zero? (pipe-content-length prefix-i)))
(make-input-port
(object-name base-p)
;; read
(lambda (bstr)
(define n (read-bytes-avail!* bstr
(if (prefix-done?)
base-p
prefix-i)))
(if (equal? n 0)
(wrap-evt base-p (lambda (v) 0))
n))
;; peek
(lambda (bstr offset evt)
(define pre-n (pipe-content-length prefix-i))
(define n (if (offset . >= . pre-n)
(peek-bytes-avail!* bstr
(- offset pre-n)
#f
base-p)
(peek-bytes-avail!* bstr
offset
#f
prefix-i)))
(if (equal? n 0)
(wrap-evt base-p (lambda (v) 0))
n))
;; close
(lambda ()
(close-input-port base-p))
;; get-progress-evt
;; Difficult (impossible?) to support at the
;; prefix--base boundary.
#f
;; commit
#f
;; get-location
(lambda ()
(if (prefix-done?)
(port-next-location base-p)
(port-next-location prefix-i)))
;; count-lines!
(lambda ()
(port-count-lines! prefix-i)
(port-count-lines! base-p))))
(define (require-input-port p [name (gensym)])
(define module-name (make-resolved-module-path name))
(parameterize ([current-module-declare-name module-name])
(eval-syntax (check-module-form ; ensures that `module` is bound
(with-module-reading-parameterization
(lambda ()
(read-syntax (object-name p) p)))
'ignored
#f)))
(dynamic-require module-name #f))
(define (normalize-error-location location)
(list
;; decrement the line number to take our #lang line back
(sub1 (first location))
;; increment the column number: in Racket ports, column numbers
;; are 0-based, while we want 1-based
(add1 (second location))))
(define (run path)
(define p
(prefix-input-port
#"#lang mylang\n"
(open-input-file path)))
(port-count-lines! p)
(define path-norm (normalize-path path))
(define error-location (void))
(define error-message (void))
(with-handlers
((exn:fail:syntax?
(lambda (e)
(set! error-message (exn-message e))
(let ((stx (last (exn:fail:syntax-exprs e))))
(when (equal? (normalize-path (syntax-source stx)) path-norm)
(set! error-location
(normalize-error-location (list (syntax-line stx)
(syntax-column stx)))))
)))
(exn:fail?
(lambda (e)
(set! error-message (exn-message e))
(for ((stack-elem (continuation-mark-set->list
(exn-continuation-marks e) errortrace-key))
#:break (not (void? error-location)))
(let ((s (cadr stack-elem)))
(when (and (path? s)
(equal? (normalize-path s) path-norm))
(set! error-location
(normalize-error-location (cddr stack-elem)))))))))
(require-input-port p))
(unless (void? error-location)
(fprintf (current-error-port) "error at line ~a, column ~a:\n"
(first error-location)
(second error-location)))
(unless (void? error-message)
(fprintf (current-error-port) "~a\n" error-message)
(exit -1))
(void))
--
You received this message because you are subscribed to the Google Groups "Racket
Users" group.
To unsubscribe from this group and stop receiving emails from it, send an email
to [email protected].
For more options, visit https://groups.google.com/d/optout.
