You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
beautiful-racket/beautiful-racket-demo/basic-demo/expander.rkt

46 lines
1.7 KiB
Racket

8 years ago
#lang br/quicklang
8 years ago
7 years ago
(define-exn-srcloc duplicate-line-number exn:fail)
(define-macro (b-module-begin (b-program LINE ...))
#'(#%module-begin
(define lines (sort (list LINE ...) #:key $line-number <))
(unless (apply < (map $line-number lines))
(raise-duplicate-line-number
($line-srcloc (check-duplicates lines = #:key $line-number))))
(run lines)))
7 years ago
(provide (rename-out [b-module-begin #%module-begin]))
7 years ago
(struct $line (number thunk srcloc) #:transparent)
(define-macro (b-line LINE-NUMBER STATEMENT)
(with-pattern ([CALLER-STX caller-stx])
7 years ago
#'($line LINE-NUMBER (λ () STATEMENT) (syntax-srcloc #'CALLER-STX))))
7 years ago
7 years ago
(define (b-statement stmt) stmt)
7 years ago
(define (b-rem str) #f)
(define (b-print str) (displayln str))
(define (b-goto line-number) line-number)
(define-exn end-program-signal exn:fail)
(define (b-end) (raise-end-program-signal))
7 years ago
(provide b-line b-statement b-rem b-print b-goto b-end)
7 years ago
(define-exn-srcloc line-not-found exn:fail)
(define (run lines)
(define line-vec (list->vector lines))
(define line-idx-table (for/hasheqv ([(line idx) (in-indexed line-vec)])
(values ($line-number line) idx)))
(with-handlers ([end-program-signal? void])
(for/fold ([line-idx 0])
([i (in-naturals)])
(unless (< line-idx (vector-length line-vec)) (b-end))
(define this-line (vector-ref line-vec line-idx))
(define this-thunk ($line-thunk this-line))
(define this-result (this-thunk))
(if (exact-positive-integer? this-result)
(hash-ref line-idx-table this-result
7 years ago
(λ () (raise-line-not-found ($line-srcloc this-line))))
7 years ago
(add1 line-idx)))))