Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

103 lines (87 sloc) 3.635 kb
#lang planet dyoo/whalesong
(require "semantics.rkt"
(for-syntax racket/base))
(provide greater-than
less-than
plus
minus
period
comma
brackets
(rename-out [my-module-begin #%module-begin]))
;; Every module in this language will make sure that it
;; uses a fresh state. We create one, and then within
;; the lexical context of a my-module-begin, all the
;; other forms will refer to current-state.
(define-syntax (my-module-begin stx)
(syntax-case stx ()
[(_ body ...)
(with-syntax ([current-data (datum->syntax stx 'current-data)]
[current-ptr (datum->syntax stx 'current-ptr)])
(syntax/loc stx
(#%plain-module-begin
(define-values (current-data current-ptr) (new-state))
(define (run)
(begin body ... (void)))
(run))))]))
;; In order to produce good runtime error messages
;; for greater-than and less-than, we latch onto
;; the syntax object for dear life, since it has
;; information about where it came from in the
;; source syntax.
;;
;; The #'#,stx nonsense below allows us to pass the
;; syntax object. The semantics can then raise an
;; appropriate syntactic error with raise-syntax-error
;; if it sees anything bad happen at runtime.
(define-syntax (greater-than stx)
(with-syntax ([current-data (datum->syntax stx 'current-data)]
[current-ptr (datum->syntax stx 'current-ptr)])
(syntax-case stx ()
[(_)
(quasisyntax/loc stx
(increment-ptr current-data current-ptr
(srcloc '#,(syntax-source stx)
'#,(syntax-line stx)
'#,(syntax-column stx)
'#,(syntax-position stx)
'#,(syntax-span stx))))])))
(define-syntax (less-than stx)
(syntax-case stx ()
[(_)
(with-syntax ([current-data (datum->syntax stx 'current-data)]
[current-ptr (datum->syntax stx 'current-ptr)])
(quasisyntax/loc stx
(decrement-ptr current-data current-ptr
(srcloc '#,(syntax-source stx)
'#,(syntax-line stx)
'#,(syntax-column stx)
'#,(syntax-position stx)
'#,(syntax-span stx)))))]))
(define-syntax (plus stx)
(with-syntax ([current-data (datum->syntax stx 'current-data)]
[current-ptr (datum->syntax stx 'current-ptr)])
(syntax/loc stx
(increment-byte current-data current-ptr))))
(define-syntax (minus stx)
(with-syntax ([current-data (datum->syntax stx 'current-data)]
[current-ptr (datum->syntax stx 'current-ptr)])
(syntax/loc stx
(decrement-byte current-data current-ptr))))
(define-syntax (period stx)
(with-syntax ([current-data (datum->syntax stx 'current-data)]
[current-ptr (datum->syntax stx 'current-ptr)])
(syntax/loc stx
(write-byte-to-stdout current-data current-ptr))))
(define-syntax (comma stx)
(with-syntax ([current-data (datum->syntax stx 'current-data)]
[current-ptr (datum->syntax stx 'current-ptr)])
(syntax/loc stx
(read-byte-from-stdin current-data current-ptr))))
(define-syntax (brackets stx)
(syntax-case stx ()
[(_ body ...)
(with-syntax ([current-data (datum->syntax stx 'current-data)]
[current-ptr (datum->syntax stx 'current-ptr)])
(syntax/loc stx
(loop current-data current-ptr body ...)))]))
Jump to Line
Something went wrong with that request. Please try again.