From aa4315477743de99e2a85fab51ce1c8a1af2b3d2 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 28 Jan 2017 18:10:00 -0800 Subject: [PATCH] the tightening --- beautiful-racket-demo/basic-demo/expander.rkt | 54 +++++++++++-------- beautiful-racket-demo/basic-demo/main.rkt | 11 ++-- beautiful-racket-demo/basic-demo/parser.rkt | 27 ++++------ beautiful-racket-demo/basic-demo/sample.rkt | 12 ++--- .../basic-demo/tokenizer.rkt | 15 +++--- beautiful-racket-lib/br/exception.rkt | 7 --- beautiful-racket-lib/br/main.rkt | 4 +- beautiful-racket-lib/br/syntax.rkt | 7 ++- 8 files changed, 71 insertions(+), 66 deletions(-) diff --git a/beautiful-racket-demo/basic-demo/expander.rkt b/beautiful-racket-demo/basic-demo/expander.rkt index f9175ac..e1473d8 100644 --- a/beautiful-racket-demo/basic-demo/expander.rkt +++ b/beautiful-racket-demo/basic-demo/expander.rkt @@ -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))))) diff --git a/beautiful-racket-demo/basic-demo/main.rkt b/beautiful-racket-demo/basic-demo/main.rkt index 2635844..fafa851 100644 --- a/beautiful-racket-demo/basic-demo/main.rkt +++ b/beautiful-racket-demo/basic-demo/main.rkt @@ -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)))) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/parser.rkt b/beautiful-racket-demo/basic-demo/parser.rkt index cbd5c2f..8f9abf8 100644 --- a/beautiful-racket-demo/basic-demo/parser.rkt +++ b/beautiful-racket-demo/basic-demo/parser.rkt @@ -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" \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/sample.rkt b/beautiful-racket-demo/basic-demo/sample.rkt index 86efe99..174d944 100644 --- a/beautiful-racket-demo/basic-demo/sample.rkt +++ b/beautiful-racket-demo/basic-demo/sample.rkt @@ -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 \ No newline at end of file +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 \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/tokenizer.rkt b/beautiful-racket-demo/basic-demo/tokenizer.rkt index 06ad50a..d4834d3 100644 --- a/beautiful-racket-demo/basic-demo/tokenizer.rkt +++ b/beautiful-racket-demo/basic-demo/tokenizer.rkt @@ -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))) \ No newline at end of file + (define (next-token) (basic-lexer ip)) + next-token) \ No newline at end of file diff --git a/beautiful-racket-lib/br/exception.rkt b/beautiful-racket-lib/br/exception.rkt index 77241fc..7dc9798 100644 --- a/beautiful-racket-lib/br/exception.rkt +++ b/beautiful-racket-lib/br/exception.rkt @@ -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) diff --git a/beautiful-racket-lib/br/main.rkt b/beautiful-racket-lib/br/main.rkt index b1d1e2c..9c2d078 100644 --- a/beautiful-racket-lib/br/main.rkt +++ b/beautiful-racket-lib/br/main.rkt @@ -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 diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index db25fb0..9ad9353 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/beautiful-racket-lib/br/syntax.rkt @@ -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))