mbutterick
/
beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

the tightening

Browse Source
pull/10/head
Matthew Butterick 8 years ago
parent afa9af72d8
commit aa43154777
8 changed files with 71 additions and 66 deletions
Show Stats Download Patch File Download Diff File

54
beautiful-racket-demo/basic-demo/expander.rkt
Unescape Escape View File

@ -1,46 +1,54 @@
#lang br/quicklang
(provide (rename-out [b-module-begin #%module-begin])
(matching-identifiers-out #rx"^b-" (all-defined-out)))
(define-macro (b-module-begin (b-program LINE ...))
(with-pattern ([(LINE-NUM ...)
(filter-stx-prop 'b-line-number (syntax-flatten #'(LINE ...)))]
[(LINE-ID ...) (syntax-map (λ (stx) (prefix-id "line-" stx)) #'(LINE-NUM ...))])
(filter-stx-prop 'b-line-number (stx-flatten #'(LINE ...)))]
[(LINE-ID ...) (prefix-ids "line-" #'(LINE-NUM ...))])
#'(#%module-begin
LINE ...
(define line-table (apply hasheqv (append (list LINE-NUM LINE-ID) ...)))
(define line-table
(apply hasheqv (append (list LINE-NUM LINE-ID) ...)))
(run line-table))))
(provide (rename-out [b-module-begin #%module-begin]))
(define-macro (b-line LINE-NUMBER STATEMENT)
(define-macro (b-line LINE-NUMBER STATEMENT ...)
(with-pattern ([LINE-NUMBER-ID (prefix-id "line-" #'LINE-NUMBER
#:source #'LINE-NUMBER)]
[ORIG-LOC caller-stx])
(syntax/loc caller-stx (define (LINE-NUMBER-ID #:srcloc? [srcloc #f])
(if srcloc
(syntax-srcloc #'ORIG-LOC)
STATEMENT)))))
(syntax/loc caller-stx
(define (LINE-NUMBER-ID #:srcloc? [srcloc #f])
(if srcloc
(syntax-srcloc #'ORIG-LOC)
(begin STATEMENT ...))))))
(define (b-statement stmt) stmt)
(define (b-rem str) #f)
(define (b-print str) (displayln str))
(define (b-goto line-number) line-number)
(define b-rem void)
(define (b-print [val ""]) (displayln val))
(define (b-sum . nums) (apply + nums))
(define (b-expr expr)
(if (integer? expr) (inexact->exact expr) expr))
(define-exn end-program-signal exn:fail)
(define (b-end) (raise-end-program-signal))
(struct $program-end-signal ())
(define (b-end) (raise ($program-end-signal)))
(provide b-line b-statement b-rem b-print b-goto b-end)
(struct $change-line-signal (num))
(define (b-goto expr) (raise ($change-line-signal expr)))
(define-exn-srcloc line-not-found exn:fail)
(define-exn line-not-found exn:fail)
(define (run line-table)
(define line-vec (list->vector (sort (hash-keys line-table) <)))
(with-handlers ([end-program-signal? void])
(with-handlers ([$program-end-signal? void])
(for/fold ([line-idx 0])
([i (in-naturals)])
(unless (< line-idx (vector-length line-vec)) (b-end))
(define line-num (vector-ref line-vec line-idx))
(define line-proc (hash-ref line-table line-num))
(define line-result (line-proc))
(if (exact-positive-integer? line-result)
(or (vector-member line-result line-vec)
(raise-line-not-found (line-proc #:srcloc? #t)))
(add1 line-idx)))))
(with-handlers ([$change-line-signal?
(λ (cls)
(or
(and (exact-positive-integer? ($change-line-signal-num cls))
(vector-member ($change-line-signal-num cls) line-vec))
(raise-line-not-found (line-proc #:srcloc? #t))))])
(line-proc)
(add1 line-idx)))))

11
beautiful-racket-demo/basic-demo/main.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang br/quicklang
(require "parser.rkt" "tokenizer.rkt")
(require "parser.rkt" "tokenizer.rkt" brag/support)
(module+ reader (provide read-syntax))
@ -8,7 +8,8 @@
(define port+newline (input-port-append #f port (open-input-string "\n")))
(port-count-lines! port+newline)
(set-port-next-location! port+newline line col pos)
(define parse-tree (parse path (tokenize port+newline)))
(strip-bindings
#`(module basic-mod basic-demo/expander
#,parse-tree)))
(with-handlers ([exn:fail:parsing? (λ (exn) (displayln "Sorry!") (raise exn))])
(define parse-tree (parse path (make-tokenizer port+newline)))
(strip-bindings
#`(module basic-mod basic-demo/expander
#,parse-tree))))

27
beautiful-racket-demo/basic-demo/parser.rkt
Unescape Escape View File

@ -1,20 +1,15 @@
#lang brag
b-program : b-line*
b-line: @b-line-number b-statement
b-line-number : NUMBER
b-statement: b-rem
| b-print
| b-goto
| b-end
b-line : @b-line-number b-statement (/":" b-statement)*
b-line-number : INTEGER
@b-statement : b-rem
| b-print
| b-goto
| b-end
b-rem : REM
b-print : /"print" STRING
b-goto : /"goto" NUMBER
b-print : /"print" (STRING | b-expr)*
b-goto : /"goto" b-expr
b-expr : b-sum
b-sum : (b-number /"+")* b-number
@b-number : INTEGER | DECIMAL
b-end : /"end"

12
beautiful-racket-demo/basic-demo/sample.rkt
Unescape Escape View File

@ -1,8 +1,8 @@
#lang basic-demo
30 rem print "nope"
30 rem print "statement ignored"
40 end
50 print "never"
60 print "second"
70 goto 30
10 print "first"
20 goto 60
50 print "never gets here"
60 print "two" : print 1.2 + 1.8
70 goto 11 + 10.5 + 8.5
10 print "one"
20 print : goto 60 : end

15
beautiful-racket-demo/basic-demo/tokenizer.rkt
Unescape Escape View File

@ -6,12 +6,15 @@
(lexer-srcloc
[(eof) eof]
[whitespace (token lexeme #:skip? #t)]
[(from/to "rem" "\n") (token 'REM (string-downcase lexeme))]
[(:or "print" "goto" "end") (token (string-downcase lexeme)
(string-downcase lexeme))]
[(:+ numeric) (token 'NUMBER (string->number lexeme))]
[(from/to "rem" "\n") (token 'REM lexeme)]
[(:or "print" "goto" "end" "+" ":") lexeme]
[(:+ numeric) (token 'INTEGER (string->number lexeme))]
[(:or (:seq (:+ numeric) ".")
(:seq (:* numeric) "." (:+ numeric)))
(token 'DECIMAL (string->number lexeme))]
[(from/to "\"" "\"") (token 'STRING (trim-ends "\"" lexeme "\""))]))
(define (tokenize ip)
(define (make-tokenizer ip)
(port-count-lines! ip)
(λ () (basic-lexer ip)))
(define (next-token) (basic-lexer ip))
next-token)

7
beautiful-racket-lib/br/exception.rkt
Unescape Escape View File

@ -3,13 +3,6 @@
(provide (all-defined-out))
(define-macro (define-exn EXN-ID BASE-EXN)
(with-pattern ([RAISE-EXN-ID (prefix-id "raise-" #'EXN-ID)])
#'(begin
(struct EXN-ID BASE-EXN () #:transparent)
(define (RAISE-EXN-ID)
(raise (EXN-ID (format "error: ~a" 'EXN-ID) (current-continuation-marks)))))))
(define-macro (define-exn-srcloc EXN-ID BASE-EXN)
(with-pattern ([RAISE-EXN-ID (prefix-id "raise-" #'EXN-ID)])
#'(begin
(define-struct (EXN-ID BASE-EXN)

4
beautiful-racket-lib/br/main.rkt
Unescape Escape View File

@ -1,9 +1,9 @@
#lang racket/base
(require racket/provide racket/list racket/string racket/format racket/match racket/port racket/function
(require racket/provide racket/list racket/string racket/format racket/match racket/port racket/function racket/provide
br/define br/syntax br/datum br/debug br/cond br/case br/exception br/list racket/class racket/vector br/reader-utils
(for-syntax racket/base racket/syntax br/syntax br/debug br/define br/datum))
(provide (all-from-out racket/base)
(all-from-out racket/list racket/string racket/format racket/match racket/port racket/function
(all-from-out racket/list racket/string racket/format racket/match racket/port racket/function racket/provide
br/syntax br/datum br/debug br/cond br/case br/exception br/list racket/class racket/vector br/define br/reader-utils)
(for-syntax (all-from-out racket/base racket/syntax br/syntax br/debug br/datum))
(for-syntax caller-stx with-shared-id)) ; from br/define

7
beautiful-racket-lib/br/syntax.rkt
Unescape Escape View File

@ -10,9 +10,14 @@
br/private/syntax-flatten)
(provide (all-defined-out)
syntax-flatten
stx-map
(rename-out [strip-context strip-bindings]
[replace-context replace-bindings]
[stx-map syntax-map]))
[stx-map syntax-map]
[syntax-flatten stx-flatten]
[prefix-id prefix-ids]
[suffix-id suffix-ids]
[infix-id infix-ids]))
(module+ test
(require rackunit))

Write Preview
Loading…
Cancel
Save