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 racket-users+unsubscr...@googlegroups.com.
For more options, visit https://groups.google.com/d/optout.
