suzanne.soy/beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compare commits

base: suzanne.soy:master
Branches Tags
suzanne.soy:master
suzanne.soy:doc-fixes
suzanne.soy:dev-elider
suzanne.soy:dev-elider-2
suzanne.soy:dev-elider-3
..
compare: suzanne.soy:dev-elider-2
Branches Tags
suzanne.soy:doc-fixes
suzanne.soy:master
suzanne.soy:dev-elider
suzanne.soy:dev-elider-2
suzanne.soy:dev-elider-3

1 Commits
master ... dev-elider

Author SHA1 Message Date
Matthew Butterick
aef9f8e9ae hmm 2016-05-04 17:33:20 -07:00
188 changed files with 1987 additions and 4341 deletions
Show Stats Expand all files Collapse all files

6
.travis.yml
View File

@ -14,8 +14,6 @@ env:
# - RACKET_VERSION=6.2
- RACKET_VERSION=6.3
- RACKET_VERSION=6.4
- RACKET_VERSION=6.5
- RACKET_VERSION=6.6
- RACKET_VERSION=HEAD
# You may want to test against certain versions of Racket, without
@ -38,7 +36,7 @@ script:
# don't rely on package server
- travis_retry raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=beautiful-racket-lib
- raco test -p beautiful-racket-lib
- travis_retry raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=brag
- raco test -p brag
- travis_retry raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=beautiful-racket-ragg
- raco test -p beautiful-racket-ragg
- travis_retry raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=beautiful-racket
- raco test -p beautiful-racket

3
README.md
View File

@ -4,15 +4,12 @@ beautiful-racket [![Build Status](https://travis-ci.org/mbutterick/beautiful-rac
Resources for the upcoming “Beautiful Racket” book, including:
* `#lang br` teaching language
* `#lang brag` parser generator language (a fork of Danny Yoo's [ragg](http://github.com/jbclements/ragg))
* supporting modules
* sample languages
Installation:
`raco pkg install beautiful-racket`

36
beautiful-racket-lib/br/cond.rkt
View File

@ -1,36 +0,0 @@
#lang racket/base
(require (for-syntax racket/base br/syntax)
br/define)
(provide (all-defined-out))
(define-macro (until COND EXPR ...)
#'(let loop ()
(unless COND
EXPR ...
(loop))))
(define-macro (while COND EXPR ...)
#'(let loop ()
(when COND
EXPR ...
(loop))))
(define-macro (forever . EXPRS)
;; todo: would be better with a syntax parameter
(with-pattern
([stop (datum->syntax #'EXPRS 'stop)])
#'(let/ec stop
(while #t
. EXPRS))))
(module+ test
(require rackunit)
(check-equal? (let ([x 5])
(until (zero? x)
(set! x (- x 1)))
x) 0)
(check-equal? (let ([x 5])
(while (positive? x)
(set! x (- x 1)))
x) 0))

15
beautiful-racket-lib/br/conditional.rkt Normal file
View File

@ -0,0 +1,15 @@
#lang racket/base
(require (for-syntax racket/base))
(provide (all-defined-out))
(define-syntax-rule (until cond expr ...)
(let loop ()
(unless cond
expr ...
(loop))))
(define-syntax-rule (while cond expr ...)
(let loop ()
(when cond
expr ...
(loop))))

33
beautiful-racket-lib/br/datum.rkt
View File

@ -1,29 +1,31 @@
#lang racket/base
(require (for-syntax racket/base br/syntax) br/define)
(provide (except-out (all-defined-out) string->datum))
(provide (all-defined-out))
;; read "foo bar" the same way as "(foo bar)"
;; otherwise "bar" is dropped, which is too astonishing
;; other "bar" is dropped, which is too astonishing
(define (string->datum str)
(if (positive? (string-length str))
(let ([result (read (open-input-string (format "(~a)" str)))])
(if (= (length result) 1)
(car result)
result))
(void)))
(let ([result (read (open-input-string (format "(~a)" str)))])
(if (= (length result) 1)
(car result)
result)))
(define (datum? x)
(or (list? x) (symbol? x)))
#;(define-syntax format-datum
(λ(stx)
(syntax-case stx (quote datum)
[(_ (quote <datum-template>) <arg> ...)
#'(format-datum (datum <datum-template>) <arg> ...)]
[(_ (datum datum-template) <arg> ...)
(syntax-let ([#'format-string (format "~a" (syntax->datum #'datum-template))])
#'(string->datum (apply format format-string (map (λ(arg) (if (syntax? arg)
(syntax->datum arg)
arg)) (list <arg> ...)))))])))
(define (format-datum datum-template . args)
(string->datum (apply format (format "~a" datum-template) (map (λ(arg) (if (syntax? arg)
(syntax->datum arg)
arg)) args))))
;; todo: rephrase errors from `format` or `map` in terms of `format-datums`
(define (format-datums datum-template . argss)
(apply map (λ args (apply format-datum datum-template args)) argss))
(module+ test
(require rackunit syntax/datum)
(check-equal? (string->datum "foo") 'foo)
@ -34,5 +36,4 @@
(check-equal? (format-datum '(~a-bar-~a) #'foo #'zam) '(foo-bar-zam))
(check-equal? (format-datum (datum (~a-bar-~a)) "foo" "zam") '(foo-bar-zam))
(check-equal? (format-datum '~a "foo") 'foo)
(check-equal? (format-datum (datum ~a) "foo") 'foo)
(check-equal? (format-datums '(put ~a) '("foo" "zam")) '((put foo) (put zam))))
(check-equal? (format-datum (datum ~a) "foo") 'foo))

31
beautiful-racket-lib/br/debug.rkt
View File

@ -1,26 +1,17 @@
#lang racket/base
(require (for-syntax racket/base br/syntax)
br/define)
(require (for-syntax racket/base racket/syntax))
(provide (all-defined-out))
(define-macro-cases report
[(_ EXPR) #'(report EXPR EXPR)]
[(_ EXPR NAME)
#'(let ([expr-result EXPR])
(eprintf "~a = ~v\n" 'NAME expr-result)
expr-result)])
(define-syntax (report stx)
(syntax-case stx ()
[(_ expr) #'(report expr expr)]
[(_ expr name)
#'(let ([expr-result expr])
(eprintf "~a = ~v\n" 'name expr-result)
expr-result)]))
(define-macro-cases report-datum
[(_ STX-EXPR)
(with-pattern ([datum (syntax->datum #'STX-EXPR)])
#'(report-datum STX-EXPR datum))]
[(_ STX-EXPR NAME)
#'(let ()
(eprintf "~a = ~v\n" 'NAME (syntax->datum STX-EXPR))
STX-EXPR)])
(define-macro (define-multi-version MULTI-NAME NAME)
#'(define-macro (MULTI-NAME X (... ...))
#'(begin (NAME X) (... ...))))
(define-syntax-rule (define-multi-version multi-name name)
(define-syntax-rule (multi-name x (... ...))
(begin (name x) (... ...))))
(define-multi-version report* report)

482
beautiful-racket-lib/br/define.rkt
View File

@ -1,262 +1,284 @@
#lang racket/base
(require
racket/function
(for-syntax racket/base
syntax/parse
br/private/syntax-flatten
syntax/define))
(provide (all-defined-out)
(for-syntax with-shared-id))
(require (for-syntax racket/list racket/base syntax/parse racket/syntax syntax/datum syntax/strip-context racket/string) sugar/define)
(provide (all-defined-out))
(module+ test
(require rackunit))
;; everything is prefixed br: whether it needs it or not so it can be stripped by #lang br
(define-for-syntax (syntax-flatten stx)
(flatten
(let loop ([stx stx])
(define maybe-list (syntax->list stx))
(if maybe-list
(map loop maybe-list)
stx))))
(define-syntax (define+provide stx)
(with-syntax ([(id lambda-exp)
(let-values ([(id-stx body-exp-stx)
(normalize-definition stx (datum->syntax stx 'λ) #t #t)])
(list id-stx body-exp-stx))])
#'(begin
(provide id)
(define id lambda-exp))))
(define-for-syntax (generate-literals pats)
;; generate literals for any symbols that are not ... or _ or _underscore-prefixed
(define pattern-arg-prefixer "_")
(for/list ([pat-arg (in-list (syntax-flatten pats))]
#:when (let ([pat-datum (syntax->datum pat-arg)])
(and (symbol? pat-datum)
(not (member pat-datum '(... _ else))) ; exempted from literality
(not (string-prefix? (symbol->string pat-datum) pattern-arg-prefixer)))))
pat-arg))
;; expose the caller context within br:define macros with syntax parameter
(begin-for-syntax
(define (upcased-and-capitalized? str)
(and (equal? (string-upcase str) str)
(not (equal? (string-downcase (substring str 0 1)) (substring str 0 1)))))
(define (generate-literals pats)
;; generate literals for any symbols that are not ... or _
(define pattern-arg-prefixer "_")
(for*/list ([pat-arg (in-list (syntax-flatten pats))]
[pat-datum (in-value (syntax->datum pat-arg))]
#:when (and (symbol? pat-datum)
(not (member pat-datum '(... _))) ; exempted from literality
(not (upcased-and-capitalized? (symbol->string pat-datum)))))
pat-arg)))
(begin-for-syntax
;; expose the caller context within br:define macros with syntax parameter
(require (for-syntax racket/base) racket/stxparam)
(provide caller-stx)
(define-syntax-parameter caller-stx (λ(stx) (error 'caller-stx-not-parameterized))))
(provide caller-stx shared-syntax)
(define-syntax-parameter caller-stx (λ(stx) (error 'caller-stx-not-parameterized)))
(define-syntax-parameter shared-syntax (λ(stx) (error 'shared-syntax-not-parameterized))))
(define-syntax (define-cases stx)
(syntax-parse stx
#:literals (syntax)
[(_ id:id)
(raise-syntax-error 'define-cases "no cases given" (syntax->datum #'id))]
[(_ id:id [(_ . pat-args:expr) . body:expr] ...)
#'(define id
(case-lambda
[pat-args . body] ...
[rest-pat (apply raise-arity-error 'id (normalize-arity (map length '(pat-args ...))) rest-pat)]))]
[else (raise-syntax-error
'define-cases
"no matching case for calling pattern"
(syntax->datum stx))]))
(module+ test
(define-cases f
[(_ arg) (add1 arg)]
[(_ arg1 arg2) (+ arg1 arg2)]
[(_ . any) 'boing])
(check-equal? (f 42) 43)
(check-equal? (f 42 5) 47)
(check-equal? (f 42 5 'zonk) 'boing)
(define-cases f-one-arg
[(_ arg) (add1 arg)])
(check-exn exn:fail:contract:arity? (λ _ (f-one-arg 1 2 3))))
(define-syntax-rule (debug-define-macro (ID . PAT-ARGS) BODY)
(define-macro (ID . PAT-ARGS)
#`(begin
(for-each displayln
(list
(format "input pattern = #'~a" '#,'(ID . PAT-ARGS))
(format "output pattern = #'~a" (cadr '#,'BODY))
(format "invoked as = ~a" (syntax->datum #'(ID . PAT-ARGS)))
(format "expanded as = ~a" '#,(syntax->datum BODY))
(format "evaluated as = ~a" #,BODY)))
#,BODY)))
(module+ test
(require rackunit racket/port)
(parameterize ([current-output-port (open-output-nowhere)])
(check-equal? (let ()
(debug-define-macro (foo X Y Z)
#'(apply + (list X Y Z)))
(foo 1 2 3)) 6)
(check-equal? (let ()
(debug-define-macro (foo X ...) #'(apply * (list X ...)))
(foo 10 11 12)) 1320)))
(begin-for-syntax
(begin-for-syntax
(require (for-syntax racket/base))
(define-syntax-rule (make-shared-syntax-macro caller-stx)
#'(syntax-rules stx
[(_ form)
#'(datum->syntax caller-stx (if (syntax? form)
(syntax-e form)
form))]))))
(module+ test
(define-macro (dirty-maker ARG)
(with-syntax ([dirty-bar (datum->syntax caller-stx 'dirty-bar)])
#'(define dirty-bar (* ARG 2))))
(dirty-maker 42)
(check-equal? dirty-bar 84))
(begin-for-syntax
(define-syntax-rule (with-shared-id (id ...) . body)
(with-syntax ([id (datum->syntax caller-stx 'id)] ...)
. body)))
;; `syntax-parse` classes shared by `define-macro` and `define-macro-cases`
(begin-for-syntax
(require syntax/parse)
(define-syntax (br:define-cases stx)
(define-syntax-class syntaxed-id
#:literals (syntax quasisyntax)
#:literals (syntax)
#:description "id in syntaxed form"
(pattern ([~or syntax quasisyntax] name:id)))
(pattern (syntax name:id)))
(define-syntax-class syntaxed-thing
#:literals (syntax quasisyntax)
#:literals (syntax)
#:description "some datum in syntaxed form"
(pattern ([~or syntax quasisyntax] thing:expr)))
(define-syntax-class else-clause
#:literals (else)
(pattern [else . body:expr]))
(define-syntax-class transformer-func
#:literals (lambda λ)
(pattern ([~or lambda λ] (arg:id) . body:expr))))
(define-syntax (define-macro stx)
(pattern (syntax thing:expr)))
(syntax-parse stx
[(_ id:id stxed-id:syntaxed-id)
#'(define-syntax id (make-rename-transformer stxed-id))]
[(_ id:id func:transformer-func)
#'(define-syntax id func)]
[(_ id:id func-id:id)
#'(define-syntax id func-id)]
[(_ id:id stxed-thing:syntaxed-thing)
#'(define-macro id (λ (stx) stxed-thing))]
[(_ (id:id . patargs:expr) . body:expr)
#'(define-macro-cases id [(id . patargs) (begin . body)])]
[else (raise-syntax-error
'define-macro
"no matching case for calling pattern"
(syntax->datum stx))]))
(define-syntax (define-macro-cases stx)
(syntax-parse stx
[(_ id:id)
(raise-syntax-error 'define-macro-cases "no cases given" (syntax->datum #'id))]
[(_ id:id leading-pat:expr ... else-pat:else-clause trailing-pat0:expr trailing-pat:expr ...)
(raise-syntax-error 'define-macro-cases "`else` clause must be last" (syntax->datum #'id))]
[(_ id:id (pat:expr . result-exprs:expr) ... else-clause:else-clause)
(with-syntax ([LITERALS (generate-literals #'(pat ...))])
#'(define-macro id
(λ (stx)
(define result
(syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
(syntax-case stx LITERALS
[pat . result-exprs] ...
else-clause)))
(if (syntax? result)
result
(datum->syntax #'id result)))))]
[(_ id:id pat-clause:expr ...) ; macro without `else` clause will reach this branch
#'(define-macro-cases id
pat-clause ...
[else (raise-syntax-error
'id
"no matching case for calling pattern"
(syntax->datum caller-stx))])]
[else (raise-syntax-error
'define-macro-cases
"no matching case for calling pattern"
(syntax->datum stx))]))
#:literals (syntax)
;; defective for syntax or function
[(_ top-id)
(raise-syntax-error 'define-cases "no cases given" (syntax->datum #'top-id))]
;; defective for syntax
[(_ (sid:syntaxed-id . _) . _) ; (define (#'f1 stx) expr ...)
(raise-syntax-error 'define-cases "definition of a syntax transformer must use lambda notation, because otherwise it's too easy to confuse the compile-time shape and the run-time shape" (syntax->datum #'sid.name))]
;; syntax matcher
[(_ top-id:syntaxed-id . patexprs)
;; todo: rephrase this check as a syntax-parse pattern above
(let ([all-but-last-pat-datums (map syntax->datum (syntax->list (syntax-case #'patexprs ()
[((pat result) ... last-one) #'(pat ...)])))])
(when (member 'else all-but-last-pat-datums)
(raise-syntax-error 'define-cases "else case must be last" (syntax->datum #'top-id.name))))
(with-syntax* ([((pat . result-exprs) ... else-result-exprs)
(syntax-case #'patexprs (syntax else)
[(((syntax pat) result-expr) ... (else . else-result-exprs))
#'((pat result-expr) ... else-result-exprs)]
[(((syntax pat) result-expr) ...)
#'((pat result-expr) ... (list (raise-syntax-error 'define-cases (format "no matching case for syntax pattern ~v" (syntax->datum stx)) (syntax->datum #'top-id.name))))])]
[LITERALS (generate-literals #'(pat ...))])
#'(define-syntax top-id.name (λ (stx)
(define result
(syntax-case stx LITERALS
[pat (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
(syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)])
. result-exprs))] ...
[else . else-result-exprs]))
(if (syntax? result)
result
(datum->syntax #'top-id.name result)))))]
;; function matcher
[(_ top-id:id [(_ . pat-args) . body] ...)
#'(define top-id
(case-lambda
[pat-args . body] ...
[else (raise-syntax-error 'define-cases "no matching case for argument pattern" (object-name top-id))]))]))
(module+ test
(define-macro plus (λ(stx) #'+))
(check-equal? (plus 42) +)
(define-macro plusser #'plus)
(check-equal? (plusser 42) +)
(check-equal? plusser +)
(define-macro (times [nested ARG]) #`(* ARG ARG))
(check-equal? (times [nested 10]) 100)
(define-macro timeser #'times)
(check-equal? (timeser [nested 12]) 144)
(define-macro fortytwo #`42)
(check-equal? fortytwo 42)
(check-equal? (let ()
(define-macro (foo X)
(with-syntax ([zam +])
#'(zam X X))) (foo 42)) 84)
(begin
(define-macro (redefine ID) #'(define ID 42))
(redefine zoombar)
(check-equal? zoombar 42))
;; use caller-stx parameter to introduce identifier unhygienically
(define-macro (zam ARG1 ARG2 ARG3)
(with-syntax ([dz (datum->syntax caller-stx 'dirty-zam)])
#`(define dz 'got-dirty-zam)))
(zam 'this 'that 42)
(check-equal? dirty-zam 'got-dirty-zam)
(define-macro (add X) #'(+ X X))
(check-equal? (add 5) 10)
(define-macro-cases add-again [(_ X) #'(+ X X)])
(check-equal? (add-again 5) 10)
(define-macro-cases add-3rd [(_ X) #'(+ X X)])
(check-equal? (add-3rd 5) 10)
(define-macro add-4th #'add-3rd)
(check-equal? (add-4th 5) 10)
(require rackunit)
(define foo-val 'got-foo-val)
(define (foo-func) 'got-foo-func)
(define-macro-cases op
[(_ "+") #''got-plus]
[(_ ARG) #''got-something-else]
[(_) #'(foo-func)]
[_ #'foo-val])
(br:define-cases #'op
[#'(_ "+") #''got-plus]
[#'(_ _ARG) #''got-something-else]
[#'(_) #'(foo-func)]
[#'_ #'foo-val])
(check-equal? (op "+") 'got-plus)
(check-equal? (op 42) 'got-something-else)
(check-equal? (op) 'got-foo-func)
(check-equal? op 'got-foo-val)
(define-macro-cases elseop
[(_ ARG) #''got-arg]
[else #''got-else])
(br:define-cases #'elseop
[#'(_ _arg) #''got-arg]
[else #''got-else])
(check-equal? (elseop "+") 'got-arg)
(check-equal? (elseop "+" 42) 'got-else)
(check-exn exn:fail:syntax? (λ _ (expand-once #'(br:define-cases #'badelseop
[else #''got-else]
[#'(_ _arg) #''got-arg]))))
(br:define-cases f
[(_ arg) (add1 arg)]
[(_ arg1 arg2) (+ arg1 arg2)])
(check-equal? (f 42) 43)
(check-equal? (f 42 5) 47)
(check-exn exn:fail:syntax? (λ _ (expand-once #'(br:define-cases (#'times stx stx2) #'*)))))
(check-exn exn:fail:syntax? (λ _ (expand-once #'(define-macro-cases no-cases))))
(check-exn exn:fail:syntax? (λ _ (expand-once #'(define-macro-cases badelseop
[else #''got-else]
[(_ _arg) #''got-arg]))))
(define-macro-cases no-else-macro
[(_ ARG) #''got-arg])
(check-exn exn:fail:syntax? (λ _ (expand-once #'(no-else-macro 'arg1 'arg2)))))
(define-syntax (br:define stx)
;;todo: share syntax classes
(define-syntax-class syntaxed-id
#:literals (syntax)
#:description "id in syntaxed form"
(pattern (syntax name:id)))
(define-syntax-class syntaxed-thing
#:literals (syntax)
#:description "some datum in syntaxed form"
(pattern (syntax thing:expr)))
(syntax-parse stx
#:literals (syntax)
;; syntax
[(_ (syntax (id . pat-args)) . body) ; (define #'(foo arg) #'(+ arg arg))
#'(br:define-cases (syntax id) [(syntax (_ . pat-args)) . body])]
[(_ sid:syntaxed-id sid2:syntaxed-id) ; (define #'f1 #'f2)
#'(define-syntax sid.name (make-rename-transformer sid2))]
[(_ (syntax id) (syntax thing)) ; (define #'f1 #'42)
#'(br:define-cases (syntax id) [#'_ (syntax thing)])]
[(_ (sid:syntaxed-id stx-arg ...) . exprs) ; (define (#'f1 stx) expr ...)
(raise-syntax-error 'define "definition of a syntax transformer must use lambda notation, because otherwise it's too easy to confuse the compile-time shape and the run-time shape" (syntax->datum #'sid.name))]
[(_ sid:syntaxed-id (λ (stx-arg ...) . exprs)) ; (define #'f1 (λ(stx) expr ...)
#:fail-when (not (= (length (syntax->datum #'(stx-arg ...))) 1))
(raise-syntax-error 'define "did not get exactly one argument for macro" (syntax->datum #'(stx-arg ...)))
(with-syntax ([(first-stx-arg other ...) #'(stx-arg ...)])
#'(define-syntax (sid.name first-stx-arg) . exprs))]
[(_ . args) #'(define . args)]))
(module+ test
(require rackunit)
(br:define #'plus (λ(stx) #'+))
(check-equal? (plus 42) +)
(br:define #'plusser #'plus)
(check-equal? (plusser 42) +)
(check-equal? plusser +)
(br:define #'(times [nested _ARG]) #'(* _ARG _ARG))
(check-equal? (times [nested 10]) 100)
(br:define #'timeser #'times)
(check-equal? (timeser [nested 12]) 144)
(br:define #'fortytwo #'42)
(check-equal? fortytwo 42)
(check-equal? (let ()
(br:define #'(foo _X)
(with-syntax ([zam +])
#'(zam _X _X))) (foo 42)) 84)
(check-exn exn:fail:syntax? (λ _ (expand-once #'(br:define (#'times stx stx2) #'*))))
(begin
(br:define #'(redefine _id) #'(define _id 42))
(redefine zoombar)
(check-equal? zoombar 42))
;; use caller-stx parameter to introduce identifier unhygienically
(br:define #'(zam _arg1 _arg2 _arg3)
(with-syntax ([dz (datum->syntax caller-stx 'dirty-zam)])
#`(define dz 'got-dirty-zam)))
(zam 'this 'that 42)
(check-equal? dirty-zam 'got-dirty-zam))
(define-syntax-rule (br:debug-define (syntax (id . pat-args)) body-exp)
(br:define #'(id . pat-args)
#`(begin
(for-each displayln
(list
(format "input pattern = #'~a" '#,'(id . pat-args))
(format "output pattern = #'~a" (cadr '#,'body-exp))
(format "invoked as = ~a" (syntax->datum #'(id . pat-args)))
(format "expanded as = ~a" '#,(syntax->datum body-exp))
(format "evaluated as = ~a" #,body-exp)))
#,body-exp)))
(module+ test
(require rackunit racket/port)
(parameterize ([current-output-port (open-output-nowhere)])
(check-equal? (let ()
(br:debug-define #'(foo _X _Y _Z)
#'(apply + (list _X _Y _Z)))
(foo 1 2 3)) 6)
(check-equal? (let ()
(br:debug-define #'(foo _X ...) #'(apply * (list _X ...)))
(foo 10 11 12)) 1320)))
(define-syntax-rule (br:define+provide . args)
(define+provide . args))
(define-for-syntax (expand-macro mac)
(syntax-disarm (local-expand mac 'expression #f) #f))
(define-syntax (br:define-inverting stx)
(syntax-case stx (syntax)
[(_ (syntax (_id . _pat-args)) . _syntaxexprs)
#'(br:define-cases-inverting (syntax _id)
[(syntax (_ . _pat-args)) . _syntaxexprs])]))
(begin-for-syntax
(begin-for-syntax
(require (for-syntax racket/base))
(define-syntax (make-shared-syntax-macro stx)
(syntax-case stx ()
[(_ caller-stx)
#'(λ(stx) (syntax-case stx ()
[(_ form)
#'(datum->syntax caller-stx (if (syntax? form)
(syntax-e form)
form))]))]))))
(define-syntax (br:define-cases-inverting stx)
(syntax-case stx (syntax)
[(_ (syntax _id) [(syntax _patarg) . _bodyexprs] ...)
(with-syntax ([LITERALS (generate-literals #'(_patarg ...))])
#'(define-syntax (_id stx)
(syntax-case stx ()
[(_id . rest)
(let ([expanded-stx (with-syntax ([expanded-macros (map expand-macro (syntax->list #'rest))])
#'(_id . expanded-macros))])
(define result
(syntax-case expanded-stx LITERALS
[_patarg (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
(syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)])
. _bodyexprs))] ...
[else (raise-syntax-error 'define-cases-inverting (format "no matching case for syntax pattern ~v" (syntax->datum stx)) (syntax->datum #'_id))]))
(if (syntax? result)
result
(datum->syntax #'_id result)))])))]))
(module+ test
;; an inverting macro expands its arguments.
;; so `foo` does not get `(falsy a) (falsy b) (falsy c)` as arguments,
;; but rather the result of their expansion, namely `((#f a) (#f b) (#f c))`
;; and `tree` does not get `(foo (#f a) (#f b) (#f c))` as its first argument,
;; but rather the result of its expansion, namely (a b c).
(br:define-inverting #'(tree (_id ...) _vals)
#'(let ()
(define-values (_id ...) _vals)
(list _id ...)))
(br:define-cases-inverting #'foo
[#'(_ (#f _id) ...) #'(_id ...)])
(define-syntax-rule (falsy id) (#f id))
(check-equal? (tree (foo (falsy a) (falsy b) (falsy c)) (values 1 2 3)) '(1 2 3)))

97
beautiful-racket-lib/br/eopl.rkt Normal file
View File

@ -0,0 +1,97 @@
#lang br
(require racket/struct (for-syntax br/datum))
(provide define-datatype cases occurs-free?)
#;(begin
(struct lc-exp () #:transparent)
(struct var-exp lc-exp (var) #:transparent
#:guard (λ(var name)
(unless (symbol? var)
(error name (format "arg ~a not ~a" var 'symbol?)))
(values var)))
(struct lambda-exp lc-exp (bound-var body) #:transparent
#:guard (λ(bound-var body name)
(unless (symbol? bound-var)
(error name (format "arg ~a not ~a" bound-var 'symbol?)))
(unless (lc-exp? body)
(error name (format "arg ~a not ~a" body 'lc-exp?)))
(values bound-var body)))
(struct app-exp lc-exp (rator rand) #:transparent
#:guard (λ(rator rand name)
(unless (lc-exp? rator)
(error name (format "arg ~a not ~a" rator 'lc-exp?)))
(unless (lc-exp? rand)
(error name (format "arg ~a not ~a" rand 'lc-exp?)))
(values rator rand))))
(define #'(define-datatype _base-type _base-type-predicate?
(_subtype [_field _field-predicate?] ...) ...)
#'(begin
(struct _base-type () #:transparent #:mutable)
(struct _subtype _base-type (_field ...) #:transparent #:mutable
#:guard (λ(_field ... name)
(unless (_field-predicate? _field)
(error name (format "arg ~a is not ~a" _field '_field-predicate?))) ...
(values _field ...))) ...))
(define-datatype lc-exp lc-exp?
(var-exp [var symbol?])
(lambda-exp [bound-var symbol?] [body lc-exp?])
(app-exp [rator lc-exp?] [rand lc-exp?]))
#;(define (occurs-free? search-var exp)
(cond
[(var-exp? exp) (let ([var (var-exp-var exp)])
(eqv? var search-var))]
[(lambda-exp? exp) (let ([bound-var (lambda-exp-bound-var exp)]
[body (lambda-exp-body exp)])
(and (not (eqv? search-var bound-var))
(occurs-free? search-var body)))]
[(app-exp? exp) (let ([rator (app-exp-rator exp)]
[rand (app-exp-rand exp)])
(or
(occurs-free? search-var rator)
(occurs-free? search-var rand)))]))
(define-syntax (cases stx)
(syntax-case stx (else)
[(_ <base-type> <input-var>
[<subtype> (<positional-var> ...) <body> ...] ...
[else <else-body> ...])
(inject-syntax ([#'(<subtype?> ...) (map-syntax (λ(s) (format-datum '~a? s)) #'(<subtype> ...))])
#'(cond
[(<subtype?> <input-var>) (match-let ([(list <positional-var> ...) (struct->list <input-var>)])
<body> ...)] ...
[else <else-body> ...]))]
[(_ <base-type> <input-var>
<subtype-case> ...)
#'(cases <base-type> <input-var>
<subtype-case> ...
[else (void)])]))
(define (occurs-free? search-var exp)
(cases lc-exp exp
[var-exp (var) (eqv? var search-var)]
[lambda-exp (bound-var body)
(and (not (eqv? search-var bound-var))
(occurs-free? search-var body))]
[app-exp (rator rand)
(or
(occurs-free? search-var rator)
(occurs-free? search-var rand))]))
(module+ test
(require rackunit)
(check-true (occurs-free? 'foo (var-exp 'foo)))
(check-false (occurs-free? 'foo (var-exp 'bar)))
(check-false (occurs-free? 'foo (lambda-exp 'foo (var-exp 'bar))))
(check-true (occurs-free? 'foo (lambda-exp 'bar (var-exp 'foo))))
(check-true (occurs-free? 'foo (lambda-exp 'bar (lambda-exp 'zim (lambda-exp 'zam (var-exp 'foo)))))))

73
beautiful-racket-lib/br/experimental/eopl.rkt
View File

@ -1,73 +0,0 @@
#lang br
(require racket/struct (for-syntax br/datum))
(provide define-datatype cases occurs-free?)
(define-macro (define-datatype BASE-TYPE BASE-TYPE-PREDICATE?
(SUBTYPE [FIELD FIELD-PREDICATE?] ...) ...)
#'(begin
(struct BASE-TYPE () #:transparent #:mutable)
(struct SUBTYPE BASE-TYPE (FIELD ...) #:transparent #:mutable
#:guard (λ(FIELD ... name)
(unless (FIELD-PREDICATE? FIELD)
(error name (format "arg ~a is not ~a" FIELD 'FIELD-PREDICATE?))) ...
(values FIELD ...))) ...))
(define-datatype lc-exp lc-exp?
(var-exp [var symbol?])
(lambda-exp [bound-var symbol?] [body lc-exp?])
(app-exp [rator lc-exp?] [rand lc-exp?]))
#;(define-syntax (cases stx)
(syntax-case stx (else)
[(_ _base-type INPUT-VAR
[SUBTYPE (POSITIONAL-VAR ...) . _body] ...
[else . _else-body])
(inject-syntax ([#'(_subtype? ...) (suffix-id #'(SUBTYPE ...) "?")])
#'(cond
[(_subtype? INPUT-VAR) (match-let ([(list POSITIONAL-VAR ...) (struct->list INPUT-VAR)])
. _body)] ...
[else . _else-body]))]
[(_ _base-type INPUT-VAR
SUBTYPE-CASE ...)
#'(cases _base-type INPUT-VAR
SUBTYPE-CASE ...
[else (void)])]))
(define-macro-cases cases
[(_ BASE-TYPE INPUT-VAR
[SUBTYPE (POSITIONAL-VAR ...) . BODY] ...
[else . ELSE-BODY])
(with-syntax ([(SUBTYPE? ...) (suffix-id #'(SUBTYPE ...) "?")])
#'(cond
[(SUBTYPE? INPUT-VAR) (match-let ([(list POSITIONAL-VAR ...) (struct->list INPUT-VAR)])
. BODY)] ...
[else . ELSE-BODY]))]
[(_ BASE-TYPE INPUT-VAR
SUBTYPE-CASE ...)
#'(cases BASE-TYPE INPUT-VAR
SUBTYPE-CASE ...
[else (void)])])
(define (occurs-free? search-var exp)
(cases lc-exp exp
[var-exp (var) (eqv? var search-var)]
[lambda-exp (bound-var body)
(and (not (eqv? search-var bound-var))
(occurs-free? search-var body))]
[app-exp (rator rand)
(or
(occurs-free? search-var rator)
(occurs-free? search-var rand))]))
(module+ test
(require rackunit)
(check-true (occurs-free? 'foo (var-exp 'foo)))
(check-false (occurs-free? 'foo (var-exp 'bar)))
(check-false (occurs-free? 'foo (lambda-exp 'foo (var-exp 'bar))))
(check-true (occurs-free? 'foo (lambda-exp 'bar (var-exp 'foo))))
(check-true (occurs-free? 'foo (lambda-exp 'bar (lambda-exp 'zim (lambda-exp 'zam (var-exp 'foo)))))))

127
beautiful-racket-lib/br/experimental/scope.rkt
View File

@ -1,127 +0,0 @@
#lang racket/base
(require (for-syntax racket/base br/syntax racket/syntax) syntax/strip-context racket/function)
(provide (all-defined-out))
(define (->syntax x)
(if (syntax? x) x (datum->syntax #f x)))
(define (context stx)
(hash-ref (syntax-debug-info stx) 'context))
(define-syntax-rule (scopes stx)
(format "~a = ~a" 'stx
(cons (syntax->datum stx)
(for/list ([scope (in-list (context stx))])
scope))))
(define (syntax-find stx stx-or-datum)
(unless (syntax? stx)
(raise-argument-error 'syntax-find "not given syntax object as first argument" stx))
(define datum
(cond [(syntax? stx-or-datum) (syntax->datum stx-or-datum)]
[(symbol? stx-or-datum) stx-or-datum]
[else (raise-argument-error 'syntax-find "not given syntax or datum as second argument" stx-or-datum)]))
(let/ec exit
(let loop ([so stx])
(cond
[(eq? (syntax->datum so) datum) (exit so)]
[(syntax->list so) => (curry map loop)]))))
(define-syntax (define-scope stx)
(syntax-case stx ()
[(_ id)
#'(define-scope id ())]
[(_ id scope-ids)
(with-syntax ([id-sis (suffix-id #'id "-sis")]
[add-id (prefix-id "add-" #'id)]
[flip-id (prefix-id "flip-" #'id)]
[id-binding-form (suffix-id #'id "-binding-form")]
[define-id (prefix-id "define-" #'id)]
[with-id-identifiers (infix-id "with-" #'id "-identifiers")]
[let-id-syntax (infix-id "let-" #'id "-syntax")]
[with-id-binding-form (infix-id "with-" #'id "-binding-form")]
[remove-id (prefix-id "remove-" #'id)]
[id? (suffix-id #'id "?")]
[id* (suffix-id #'id "*")]
[(scope-id-sis ...) (suffix-id #'scope-ids "-sis")])
#'(begin
(define id-sis
(let ([sis-in (list scope-id-sis ...)])
(if (pair? sis-in)
(apply append sis-in)
(list
(let ([si (make-syntax-introducer #t)])
(list (procedure-rename (curryr si 'add) 'add-id)
(procedure-rename (curryr si 'flip) 'flip-id)
(procedure-rename (curryr si 'remove) 'remove-id)))))))
(define add-id (λ(x) ((apply compose1 (map car id-sis)) (->syntax x))))
(define flip-id (λ(x) ((apply compose1 (map cadr id-sis)) (->syntax x))))
(define remove-id (λ(x) ((apply compose1 (map caddr id-sis)) (->syntax x))))
(define (id x) (add-id (datum->syntax #f (syntax-e (->syntax x)))))
(define (id-binding-form x) (syntax-local-introduce (id x)))
(define (id* x) (replace-context (add-id (datum->syntax #f '_)) (->syntax x)))
(define (id? x)
(and
(member (car (context (add-id (datum->syntax #f '_))))
(context (->syntax x)))
#t))
(define-syntax-rule (with-id-identifiers (name (... ...)) . body)
(with-syntax ([name (id* 'name)] (... ...)) . body))
(define-syntax-rule (with-id-binding-form (name (... ...)) . body)
(with-syntax ([name (id-binding-form 'name)] (... ...)) . body))
(define-syntax-rule (let-id-syntax ([pat val] (... ...)) . body)
(let-syntax ([pat (id* val)] (... ...)) . body))))]))
(define (scopes-equal? stxl stxr)
;; "A bound-identifier=? comparison checks that two identifiers have exactly the same scope sets"
(bound-identifier=? (datum->syntax stxl '_) (datum->syntax stxr '_)))
(module+ test
(require rackunit)
(define-scope red)
(define stx (datum->syntax #f 'x))
(define red-stx (add-red stx))
(define double-red-stx (add-red (add-red stx)))
(check-false (red? stx))
(check-true (red? red-stx))
(check-true (red? double-red-stx))
(check-false (scopes-equal? stx red-stx))
(check-true (scopes-equal? red-stx double-red-stx))
(check-false (scopes-equal? red-stx (remove-red double-red-stx)))
(define-scope blue) ; scope addition is commutative
(define blue-stx (blue stx))
(check-true (scopes-equal? (add-blue red-stx) (add-red blue-stx)))
(check-true (scopes-equal? (remove-red (add-blue red-stx)) (remove-red (add-red blue-stx))))
(define-scope green) ; replace scopes at outer layer
(check-true (scopes-equal? (green red-stx) (green blue-stx)))
;; replace scopes everywhere
(check-true (scopes-equal? (car (syntax->list (green* #`(#,blue-stx #,red-stx))))
(car (syntax->list (green* #`(#,red-stx #,blue-stx))))))
;; todo: test flipping
(define-scope purple (red blue))
(check-true (purple? (add-purple stx)))
(check-true (scopes-equal? (purple (green stx)) (add-blue (remove-green (add-red (add-green (add-blue stx))))))))
(define-syntax (with-scopes stx)
(syntax-case stx (syntax)
[(_ (scope-id) (syntax expr))
(with-syntax ([add-scope-id (format-id #'scope-id "add-~a" #'scope-id)])
#'(add-scope-id expr))]))

19
beautiful-racket-lib/br/get-info.rkt
View File

@ -1,19 +0,0 @@
#lang racket
(provide (all-defined-out))
(require racket/class)
(define (indenter t pos)
(with-handlers ([exn:fail? (λ(exn) #f)]) ; this function won't work until gui-lib 1.26
(send t compute-racket-amount-to-indent pos (λ(x)
(case x
[("with-pattern" "with-shared-id") 'lambda]
[("define-macro") 'define]
[else #f])))))
(define (br-get-info key default default-filter)
(case key
#;[(color-lexer)
(dynamic-require 'syntax-color/default-lexer 'default-lexer)]
[(drracket:indentation) indenter]
[else
(default-filter key default)]))

0
beautiful-racket-lib/br/experimental/load.rkt → beautiful-racket-lib/br/load.rkt
View File

34
beautiful-racket-lib/br/main.rkt
View File

@ -1,22 +1,26 @@
#lang racket/base
(require racket/provide racket/list racket/string racket/format racket/match racket/port
br/define br/syntax br/datum br/debug br/cond racket/function
(for-syntax racket/base racket/syntax br/syntax br/debug br/define))
(provide (all-from-out racket/base)
br/define br/syntax br/datum br/debug br/conditional
(for-syntax racket/base racket/syntax br/syntax br/define))
(provide (except-out (all-from-out racket/base) define)
(all-from-out racket/list racket/string racket/format racket/match racket/port
br/syntax br/datum br/debug br/cond racket/function br/define)
(for-syntax (all-from-out racket/base racket/syntax br/syntax br/debug))
(for-syntax caller-stx with-shared-id)) ; from br/define
br/syntax br/datum br/debug br/conditional)
(for-syntax (all-from-out racket/base racket/syntax br/syntax))
(for-syntax caller-stx shared-syntax) ; from br/define
(filtered-out
(λ (name)
(let ([pat (regexp "^br:")])
(and (regexp-match? pat name)
(regexp-replace pat name ""))))
(combine-out (all-from-out br/define))))
;; todo: activate at-exp reader by default
(provide evaluate)
(define-macro (evaluate DATUM)
#'(begin
(define-namespace-anchor nsa)
(eval DATUM (namespace-anchor->namespace nsa))))
(define (remove-blank-lines strs)
(filter (λ(str) (regexp-match #px"\\S" str)) strs))
(provide remove-blank-lines)
(module reader syntax/module-reader
#:language 'br
#:info br-get-info
(require br/get-info))
#:language 'br)

12
beautiful-racket-lib/br/private/syntax-flatten.rkt
View File

@ -1,12 +0,0 @@
#lang racket/base
(require racket/list)
(provide (all-defined-out))
(define (syntax-flatten stx)
(flatten
(let loop ([stx stx])
(let* ([stx-unwrapped (syntax-e stx)]
[maybe-pair (and (pair? stx-unwrapped) (flatten stx-unwrapped))])
(if maybe-pair
(map loop maybe-pair)
stx)))))

31
beautiful-racket-lib/br/quicklang.rkt
View File

@ -1,31 +0,0 @@
#lang br
(require (for-syntax racket/list sugar/debug))
(provide (except-out (all-from-out br) #%module-begin)
(rename-out [quicklang-mb #%module-begin]))
(define-macro (quicklang-mb . EXPRS)
(define-values
(kw-pairs other-exprs)
(let loop ([kw-pairs null][exprs (syntax->list #'EXPRS)])
(if (and (pair? exprs) (keyword? (syntax-e (car exprs))))
(loop (cons (cons (string->symbol (keyword->string (syntax-e (car exprs))))
(cadr exprs)) ; leave val in stx form so local binding is preserved
kw-pairs)
(cddr exprs))
(values kw-pairs exprs))))
(define reserved-keywords '(provide))
(define (reserved? kw-pair) (memq (car kw-pair) reserved-keywords))
(define-values (reserved-kwpairs other-kwpairs) (partition reserved? kw-pairs))
(with-pattern ([((KW . VAL) ...) other-kwpairs]
[(PROVIDED-ID ...) (or (assq 'provide reserved-kwpairs) null)])
#`(#%module-begin
(provide PROVIDED-ID ...)
(provide (rename-out [VAL KW]) ...)
(provide #%top #%app #%datum #%top-interaction)
. #,(datum->syntax #'EXPRS other-exprs #'EXPRS))))
(module reader syntax/module-reader
#:language 'br/quicklang
#:info br-get-info
(require br/get-info))

66
beautiful-racket-lib/br/reader-utils.rkt
View File

@ -1,41 +1,43 @@
#lang racket/base
(require (for-syntax racket/base racket/syntax br/syntax) br/define syntax/strip-context)
(require (for-syntax racket/base racket/syntax) syntax/strip-context)
(provide define-read-and-read-syntax)
;; `define-read-functions` simplifies support for the standard reading API,
;; which asks for `read` and `read-syntax`.
;; in general, `read` is just the datum from the result of `read-syntax`.
(define-macro (define-read-and-read-syntax (PATH PORT) BODY ...)
(let ([internal-prefix (gensym)])
(with-syntax ([READ (datum->syntax caller-stx 'read)]
[READ-SYNTAX (datum->syntax caller-stx 'read-syntax)]
;; use prefixed names to prevent namespace collisions with possibly existing `read` & `read-syntax`
[INTERNAL-READ (format-id #'here "~a-~a" internal-prefix 'read)]
[INTERNAL-READ-SYNTAX (format-id #'here "~a-~a" internal-prefix 'read-syntax)])
#'(begin
(provide (rename-out [INTERNAL-READ READ]
[INTERNAL-READ-SYNTAX READ-SYNTAX]))
(define (calling-site-function PATH PORT)
BODY ...) ; don't care whether this produces datum or syntax
(define-syntax (define-read-and-read-syntax calling-site-stx)
(syntax-case calling-site-stx ()
[(_ (PATH PORT) BODY ...)
(let ([internal-prefix (gensym)])
(with-syntax ([READ (datum->syntax calling-site-stx 'read)]
[READ-SYNTAX (datum->syntax calling-site-stx 'read-syntax)]
;; use prefixed names to prevent namespace collisions with possibly existing `read` & `read-syntax`
[INTERNAL-READ (format-id #'here "~a-~a" internal-prefix 'read)]
[INTERNAL-READ-SYNTAX (format-id #'here "~a-~a" internal-prefix 'read-syntax)])
#'(begin
(provide (rename-out [INTERNAL-READ READ]
[INTERNAL-READ-SYNTAX READ-SYNTAX]))
(define (calling-site-function PATH PORT)
BODY ...) ; don't care whether this produces datum or syntax
(define INTERNAL-READ-SYNTAX
(procedure-rename (λ (path port) ; rename proc so it looks right in the REPL (otherwise retains internal prefix name)
;; because `read-syntax` must produce syntax
;; coerce a datum result to syntax if needed (à la `with-syntax`)
(define result-syntax (let ([output (calling-site-function path port)])
(if (syntax? output)
output
(datum->syntax #f output))))
;; because `read-syntax` must produce syntax without context
;; see http://docs.racket-lang.org/guide/hash-lang_reader.html
;; "a `read-syntax` function should return a syntax object with no lexical context"
(strip-context result-syntax)) 'READ-SYNTAX))
(define INTERNAL-READ-SYNTAX
(procedure-rename (λ (path port) ; rename proc so it looks right in the REPL (otherwise retains internal prefix name)
;; because `read-syntax` must produce syntax
;; coerce a datum result to syntax if needed (à la `with-syntax`)
(define result-syntax (let ([output (calling-site-function path port)])
(if (syntax? output)
output
(datum->syntax #f output))))
;; because `read-syntax` must produce syntax without context
;; see http://docs.racket-lang.org/guide/hash-lang_reader.html
;; "a `read-syntax` function should return a syntax object with no lexical context"
(strip-context result-syntax)) 'READ-SYNTAX))
(define INTERNAL-READ
(procedure-rename (λ (port)
; because `read` must produce a datum
(let ([output (calling-site-function #f port)])
(if (syntax? output)
(syntax->datum output)
output))) 'READ))))))
(define INTERNAL-READ
(procedure-rename (λ (port)
; because `read` must produce a datum
(let ([output (calling-site-function #f port)])
(if (syntax? output)
(syntax->datum output)
output))) 'READ)))))]))

388
beautiful-racket-lib/br/scribblings/br.scrbl
View File

@ -1,417 +1,65 @@
#lang scribble/manual
@(require (for-label racket/base racket/contract br))
@(require scribble/eval)
@(define my-eval (make-base-eval))
@(my-eval `(require br racket/stxparam))
@(require (for-label br/conditional))
@title[#:style 'toc]{Beautiful Racket}
@author[(author+email "Matthew Butterick" "mb@mbtype.com")]
@link["http://beautifulracket.com"]{@italic{Beautiful Racket}} is a book about making programming languages with Racket.
Beautiful Racket @link["http://beautifulracket.com"]{is a book} about making programming languages with Racket.
This library provides the @tt{#lang br} teaching language used in the book, as well as supporting modules that can be used in other programs.
This library is designed to smooth over some of the small idiosyncrasies and inconsistencies in Racket, so that those new to Racket are more likely to say ``ah, that makes sense'' rather than ``huh? what?''
@;{
@section{The @tt{br} language(s)}
@;defmodulelang[br]
@defmodulelang[br]
@defmodulelang[br/quicklang]
}
@tt{#lang br} is a teaching language designed to smooth over some of the small idiosyncrasies and inconsistencies in Racket, so that those new to Racket will say ``ah, that makes sense'' rather than ``huh? what?'' @tt{#lang br} is not meant to hide the true nature of Racket, but rather defer certain parts of the learning curve.
To that end, this documentation not only explains the functions and forms in the Beautiful Racket library, but also how they depart from traditional or idiomatic Racket. (BTW ``Beautiful Racket'' is the name of the book, not an implication that the rest of Racket is less than beautiful. It is! But one thing at a time.)
@section{Conditionals}
@defmodule[br/cond]
@defmodule[br/conditional]
@defform[(while cond body ...)]{
Loop over @racket[body] as long as @racket[cond] is not @racket[#f]. If @racket[cond] starts out @racket[#f], @racket[body] is never evaluated.
@defform[(while cond body ...)]
Loop over @racket[_body] expressions as long as @racket[_cond] is not @racket[#f]. If @racket[_cond] starts out @racket[#f], @racket[_body] expressions are not evaluated.
@examples[#:eval my-eval
(let ([x 42])
(while (positive? x)
(set! x (- x 1)))
x)
(let ([x 42])
(while (negative? x)
(unleash-zombie-army))
x)
]
}
@defform[(until cond body ...)]
Loop over @racket[_body] expressions until @racket[_cond] is not @racket[#f]. If @racket[_cond] starts out @racket[#f], @racket[_body] expressions are not evaluated.
@defform[(until cond body ...)]{
Loop over @racket[body] until @racket[cond] is not @racket[#f]. If @racket[cond] starts out not @racket[#f], @racket[body] is never evaluated.
@examples[#:eval my-eval
(let ([x 42])
(until (zero? x)
(set! x (- x 1)))
x)
(let ([x 42])
(until (= 42 x)
(destroy-galaxy))
x)
]
}
@section{Datums}
@defmodule[br/datum]
A @defterm{datum} is a literal representation of a single unit of Racket code, also known as an @defterm{S-expression}. Unlike a string, a datum preserves the internal structure of the S-expression. Meaning, if the S-expression is a single value, or list-shaped, or tree-shaped, so is its corresponding datum.
Datums are made with @racket[quote] or its equivalent notation, the @litchar{'} prefix (see @secref["quote" #:doc '(lib "scribblings/guide/guide.scrbl")]).
When I use ``datum'' in its specific Racket sense, I use ``datums'' as its plural rather than ``data'' because that term has an existing, more generic meaning.
@defproc[
(format-datum
[datum-form (or/c list? symbol?)]
[val any/c?] ...)
(or/c list? symbol?)]{
Similar to @racket[format], but the template @racket[datum-form] is a datum, rather than a string, and the function returns a datum, rather than a string. Otherwise, the same formatting escapes can be used in the template (see @racket[fprintf]).
Two special cases. First, a string that describes a list of datums is parenthesized so the result is a single datum. Second, an empty string returns @racket[void] (not @racket[#f], because that's a legitimate datum).
@examples[#:eval my-eval
(format-datum '42)
(format-datum '~a "foo")
(format-datum '(~a ~a) "foo" 42)
(format-datum '~a "foo bar zam")
(void? (format-datum '~a ""))
(format-datum '~a #f)
]
}
@defproc[
(format-datums
[datum-form (or/c list? symbol?)]
[vals (listof any/c?)] ...)
(listof (or/c list? symbol?))]{
Like @racket[format-datum], but applies @racket[datum-form] to the lists of @racket[vals] in similar way to @racket[map], where values for the format string are taken from the lists of @racket[vals] in parallel. This means that a) @racket[datum-form] must accept as many arguments as there are lists of @racket[vals], and b) the lists of @racket[vals] must all have the same number of items.
@examples[#:eval my-eval
(format-datums '~a '("foo" "bar" "zam"))
(format-datums '(~a 42) '("foo" "bar" "zam"))
(format-datums '(~a ~a) '("foo" "bar" "zam") '(42 43 44))
(format-datums '42 '("foo" "bar" "zam"))
(format-datums '(~a ~a) '("foo" "bar" "zam") '(42))
]
}
[datum-template symbol?]
[arg any/c?] ...)
datum?]
tk
@section{Debugging}
@defmodule[br/debug]
@defform*[[
(report expr)
(report expr maybe-name)
]]{
Print the name and value of @racket[expr] to @racket[current-error-port], but also return the evaluated result of @racket[expr] as usual. This lets you see the value of an expression or variable at runtime without disrupting any of the surrounding code. Optionally, you can use @racket[maybe-name] to change the name shown in @racket[current-error-port].
For instance, suppose you wanted to see how @racket[first-condition?] was being evaluted in this expression:
@racketblock[
(if (and (first-condition? x) (second-condition? x))
(one-thing)
(other-thing))]
You can wrap it in @racket[report] and find out:
@racketblock[
(if (and (report (first-condition? x)) (second-condition? x))
(one-thing)
(other-thing))]
This code will run the same way as before. But when it reaches @racket[first-condition?], you willl see in @racket[current-error-port]:
@racketerror{(first-condition? x) = #t}
You can also add standalone calls to @racket[report] as a debugging aid at points where the return value will be irrelevant, for instance:
@racketblock[
(report x x-before-function)
(if (and (report (first-condition? x)) (second-condition? x))
(one-thing)
(other-thing))]
@racketerror{x-before-function = 42
@(linebreak)(first-condition? x) = #t}
But be careful — in the example below, the result of the @racket[if] expression will be skipped in favor of the last expression, which will be the value of @racket[x]:
@racketblock[
(if (and (report (first-condition? x)) (second-condition? x))
(one-thing)
(other-thing))
(report x)]
@defform[(report* expr ...)]
Apply @racket[report] separately to each @racket[expr] in the list.
@defform*[((report-datum stx-expr) (report-datum stx-expr maybe-name))]
A variant of @racket[report] for use with @secref["stx-obj" #:doc '(lib "scribblings/guide/guide.scrbl")]. Rather than print the whole object (as @racket[report] would), @racket[report-datum] prints only the datum inside the syntax object, but the return value is the whole syntax object.
}
TK
@section{Define}
@defmodule[br/define]
@defform[
(define-cases id
[pat body ...+] ...+)
]
Define a function that behaves differently depending on how many arguments are supplied (also known as @seclink["Evaluation_Order_and_Arity" #:doc '(lib "scribblings/guide/guide.scrbl")]{@italic{arity}}). Like @racket[cond], you can have any number of branches. Each branch starts with a @racket[_pat] that accepts a certain number of arguments. If the current invocation of the function matches the number of arguments in @racket[_pat], then the @racket[_body] on the right-hand side is evaluated. If there is no matching case, an arity error arises. (Derived from @racket[case-lambda], whose notation you might prefer.)
@examples[#:eval my-eval
(define-cases f
[(f arg1) (* arg1 arg1)]
[(f arg1 arg2) (* arg1 arg2)]
[(f arg1 arg2 arg3 arg4) (* arg1 arg2 arg3 arg4)])
(f 4)
(f 6 7)
(f 1 2 3 4)
(f "three" "arguments" "will-trigger-an-error")
(define-cases f2
[(f2) "got zero args"]
[(f2 . args) (format "got ~a args" (length args))])
(f2)
(f2 6 7)
(f2 1 2 3 4)
(f2 "three" "arguments" "will-not-trigger-an-error-this-time")
]
@defform*[
#:literals (syntax lambda stx)
[
(define-macro id (syntax other-id))
(define-macro id (lambda (arg-id) result-expr ...+))
(define-macro id transformer-id)
(define-macro id (syntax result-expr))
(define-macro (id pat-arg ...) expr ...+)
]]
Create a macro using one of the subforms above, which are explained below:
@specsubform[#:literals (define-macro syntax lambda stx)
(define-macro id (syntax other-id))]{
If the first argument is an identifier @racket[id] and the second a syntaxed identifier that looks like @racket[(syntax other-id)], create a rename transformer, which is a fancy term for ``macro that replaces @racket[id] with @racket[other-id].'' (This subform is equivalent to @racket[make-rename-transformer].)
Why do we need rename transformers? Because an ordinary macro operates on its whole calling expression (which it receives as input) like @racket[(macro-name this-arg that-arg . and-so-on)]. By contrast, a rename transformer operates only on the identifier itself (regardless of where that identifier appears in the code). It's like making one identifier into an alias for another identifier.
Below, notice how the rename transformer, operating in the macro realm, approximates the behavior of a run-time assignment.
@examples[#:eval my-eval
(define foo 'foo-value)
(define bar foo)
bar
(define-macro zam-macro #'foo)
zam-macro
(define add +)
(add 20 22)
(define-macro sum-macro #'+)
(sum-macro 20 22)
]
}
@specsubform[#:literals (define-macro lambda stx)
(define-macro id (lambda (arg-id) result-expr ...+))]{
If the first argument is an @racket[id] and the second a single-argument function, create a macro called @racket[id] that uses the function as a syntax transformer. This function must return a @seclink["stx-obj" #:doc '(lib "scribblings/guide/guide.scrbl")]{syntax object}, otherwise you'll trigger an error. Beyond that, the function can do whatever you like. (This subform is equivalent to @racket[define-syntax].)
@examples[#:eval my-eval
(define-macro nice-sum (lambda (stx) #'(+ 2 2)))
nice-sum
(define-macro not-nice (lambda (stx) '(+ 2 2)))
not-nice
]
}
@specsubform[#:literals (define-macro lambda stx)
(define-macro id transformer-id)]{
Similar to the previous subform, but @racket[transformer-id] holds an existing transformer function. Note that @racket[transformer-id] needs to be visible during compile time (aka @italic{phase 1}), so use @racket[define-for-syntax] or equivalent.
@examples[#:eval my-eval
(define-for-syntax summer-compile-time (lambda (stx) #'(+ 2 2)))
(define-macro nice-summer summer-compile-time)
nice-summer
(define summer-run-time (lambda (stx) #'(+ 2 2)))
(define-macro not-nice-summer summer-run-time)
]
}
@specsubform[#:literals (define-macro)
(define-macro id syntax-object)
#:contracts ([syntax-object syntax?])]{
If the first argument is an @racket[id] and the second a @racket[syntax-object], create a syntax transformer that returns @racket[syntax-object]. This is just alternate notation for the previous subform, wrapping @racket[syntax-object] inside a function body. The effect is to create a macro from @racket[id] that always returns @racket[syntax-object], regardless of how it's invoked. Not especially useful within programs. Mostly handy for making quick macros at the REPL.
@examples[#:eval my-eval
(define-macro bad-listener #'"what?")
bad-listener
(bad-listener)
(bad-listener "hello")
(bad-listener 1 2 3 4)
]
}
@specsubform[#:literals (define-macro)
(define-macro (id pat-arg ...) result-expr ...+)]{
If the first argument is a @seclink["stx-patterns" #:doc '(lib "scribblings/reference/reference.scrbl")]
{syntax pattern} starting with @racket[id], then create a syntax transformer for this pattern using @racket[result-expr ...] as the return value. As usual, @racket[result-expr ...] needs to return a @seclink["stx-obj" #:doc '(lib "scribblings/guide/guide.scrbl")]{syntax object} or you'll get an error.
The syntax-pattern notation is the same as @racket[syntax-case], with one key difference. If a @racket[pat-arg] has a @tt{CAPITALIZED-NAME}, it's treated as a named wildcard (meaning, it will match any expression in that position, and can be subsequently referred to by that name). Otherwise, @racket[pat-arg] is treated as a literal (meaning, it will only match the same expression).
For instance, the @racket[sandwich] macro below requires three arguments, and the third must be @racket[please], but the other two are wildcards:
@examples[#:eval my-eval
(define-macro (sandwich TOPPING FILLING please)
#'(format "I love ~a with ~a." 'FILLING 'TOPPING))
(sandwich brie ham)
(sandwich brie ham now)
(sandwich brie ham please)
(sandwich banana bacon please)
]
The ellipsis @racket[...] can be used with a wildcard to match a list of arguments. Please note: though a wildcard standing alone must match one argument, once you add an ellipsis, it's allowed to match zero:
@examples[#:eval my-eval
(define-macro (pizza TOPPING ...)
#'(string-join (cons "Waiter!"
(list (format "More ~a!" 'TOPPING) ...))
" "))
(pizza mushroom)
(pizza mushroom pepperoni)
(pizza)
]
The capitalization requirement for a wildcard @racket[pat-arg] makes it easy to mix literals and wildcards in one pattern. But it also makes it easy to mistype a pattern and not get the wildcard you were expecting. Below, @racket[bad-squarer] doesn't work because @racket[any-number] is meant to be a wildcard. But it's not capitalized, so it's considered a literal, and it triggers an error:
@examples[#:eval my-eval
(define-macro (bad-squarer any-number)
#'(* any-number any-number))
(bad-squarer +10i)
]
The error is cleared when the argument is capitalized, thus making it a wilcard:
@examples[#:eval my-eval
(define-macro (good-squarer ANY-NUMBER)
#'(* ANY-NUMBER ANY-NUMBER))
(good-squarer +10i)
]
@;{You can use the special identifier @racket[caller-stx] — available only within the body of @racket[define-macro] — to access the original input argument to the macro.}
@;{todo: fix this example. complains that caller-stx is unbound}
@;{
@examples[#:eval my-eval
(require (for-syntax br))
(define-macro (inspect ARG ...)
#`(displayln
(let ([calling-pattern '#,(syntax->datum caller-stx)])
(format "Called as ~a with ~a args"
calling-pattern
(length (cdr calling-pattern))))))
(inspect)
(inspect 42)
(inspect "foo" "bar")
(inspect #t #f #f #t)
]
}
This subform of @racket[define-macro] is useful for macros that have one calling pattern. To make a macro with multiple calling patterns, see @racket[define-macro-cases].
}
@defform[
(define-macro-cases id
[pattern result-expr ...+] ...+)
]{
Create a macro called @racket[id] with multiple branches, each with a @racket[pattern] on the left and @racket[result-expr] on the right. The input to the macro is tested against each @racket[pattern]. If it matches, then @racket[result-expr] is evaluated.
As with @racket[define-macro], wildcards in each syntax pattern must be @tt{CAPITALIZED}. Everything else is treated as a literal match, except for the ellipsis @racket[...] and the wildcard @racket[_].
@examples[#:eval my-eval
(define-macro-cases yogurt
[(yogurt) #'(displayln (format "No toppings? Really?"))]
[(yogurt TOPPING)
#'(displayln (format "Sure, you can have ~a." 'TOPPING))]
[(yogurt TOPPING ANOTHER-TOPPING ... please)
#'(displayln (format "Since you asked nicely, you can have ~a toppings."
(length '(TOPPING ANOTHER-TOPPING ...))))]
[(yogurt TOPPING ANOTHER-TOPPING ...)
#'(displayln (format "Whoa! Rude people only get one topping."))])
(yogurt)
(yogurt granola)
(yogurt coconut almonds hot-fudge brownie-bites please)
(yogurt coconut almonds)
]
}
TK
@section{Reader utilities}
@defmodule[br/reader-utils]
@defform[
(define-read-and-read-syntax (path-id port-id)
reader-result-expr ...+)
]{
For use within a language reader. Automatically @racket[define] and @racket[provide] the @racket[read] and @racket[read-syntax] functions needed for the reader's public interface. @racket[reader-result-expr] can return either a syntax object or a datum (which will be converted to a syntax object).
TK
The generated @racket[read-syntax] function takes two arguments, a path and an input port. It returns a syntax object stripped of all bindings.
The generated @racket[read] function takes one argument, an input port. It calls @racket[read-syntax] and converts the result to a datum.
@examples[#:eval my-eval
(module sample-reader racket/base
(require br/reader-utils racket/list)
(define-read-and-read-syntax (path port)
(add-between
(for/list ([datum (in-port read port)])
datum)
'whee)))
(require (prefix-in sample: 'sample-reader))
(define string-port (open-input-string "(+ 2 2) 'hello"))
(sample:read-syntax 'no-path string-port)
(define string-port-2 (open-input-string "(+ 2 2) 'hello"))
(sample:read string-port-2)
]
}
@;{
@section{Syntax}
@defmodule[br/syntax]
TK
}
TK

0
beautiful-racket-lib/br/experimental/stxparam.rkt → beautiful-racket-lib/br/stxparam.rkt
View File

139
beautiful-racket-lib/br/syntax.rkt
View File

@ -1,115 +1,34 @@
#lang racket/base
(require (for-syntax racket/base racket/syntax)
racket/list
racket/syntax
br/define
br/private/syntax-flatten)
(provide (all-defined-out)
syntax-flatten)
(module+ test
(require rackunit))
(require (for-syntax racket/base syntax/parse) syntax/strip-context)
(provide (all-defined-out) (all-from-out syntax/strip-context))
(define-macro (syntax-match STX-ARG [(syntax PATTERN) BODY ...] ...)
#'(syntax-case STX-ARG ()
[PATTERN BODY ...] ...))
(define-syntax (syntax-match stx)
(syntax-case stx (syntax)
[(_ stx-arg [(syntax pattern) body ...] ...)
#'(syntax-case stx-arg ()
[pattern body ...] ...)]))
(define-syntax (add-syntax stx)
;; todo: permit mixing of two-arg and one-arg binding forms
;; one-arg form allows you to inject an existing syntax object using its current name
(syntax-case stx (syntax)
[(_ ([(syntax sid) sid-stx] ...) body ...)
#'(with-syntax ([sid sid-stx] ...) body ...)]
;; todo: limit `sid` to be an identifier
[(_ ([sid] ...) body ...)
#'(with-syntax ([sid sid] ...) body ...)]))
(define-syntax syntax-let (make-rename-transformer #'add-syntax))
(define-syntax inject-syntax (make-rename-transformer #'add-syntax))
(define-syntax (map-syntax stx)
(syntax-case stx ()
[(_ <proc> <arg> ...)
#'(map <proc> (if (and (syntax? <arg>) (list? (syntax-e <arg>)))
(syntax->list <arg>)
<arg>) ...)]))
(define-macro-cases with-pattern
[(_ () . BODY) #'(begin . BODY)]
[(_ ([SID SID-STX] STX ...) . BODY)
#'(with-syntax ([SID SID-STX])
(with-pattern (STX ...) . BODY))]
[(_ ([SID] STX ...) . BODY) ; standalone id
#'(with-pattern ([SID SID] STX ...) . BODY)]) ; convert to previous case
(define (check-syntax-list-argument caller-name arg)
(cond
[(and (syntax? arg) (syntax->list arg))]
[(list? arg) arg]
[else (raise-argument-error caller-name "list of syntax, or syntaxed list" arg)]))
(define-macro (define-listy-macro MACRO-ID LIST-FUNC)
#'(define-macro (MACRO-ID STX-LIST LITERALS . MATCHERS)
#'(LIST-FUNC
(λ(stx-item)
(with-handlers ([exn:fail:syntax? (λ (exn) #f)])
(syntax-case stx-item LITERALS
. MATCHERS)))
(check-syntax-list-argument 'MACRO-ID STX-LIST))))
(define-listy-macro syntax-case-partition partition)
(define-listy-macro syntax-case-filter filter)
(define-listy-macro syntax-case-map map)
(define-macro (reformat-id FMT ID0 ID ...)
#'(format-id ID0 FMT ID0 ID ...))
(define-macro (format-string FMT ID0 ID ...)
#'(datum->syntax ID0 (format FMT (syntax->datum ID0) (syntax->datum ID) ...)))
(define-macro (->unsyntax X)
#'(if (syntax? X)
(syntax->datum X)
X))
(define-macro (prefix-id PREFIX ... BASE-OR-BASES)
#'(let* ([bobs BASE-OR-BASES]
[got-single? (and (not (list? bobs)) (not (syntax->list bobs)))]
[bases (if got-single?
(list bobs)
bobs)]
[result (syntax-case-map
bases ()
[base (format-id #'base "~a~a"
(string-append (format "~a" (->unsyntax PREFIX)) ...)
(syntax-e #'base))])])
(if got-single? (car result) result)))
(define-macro (infix-id PREFIX BASE-OR-BASES SUFFIX ...)
#'(let* ([bobs BASE-OR-BASES]
[got-single? (and (not (list? bobs)) (not (syntax->list bobs)))]
[bases (if got-single?
(list bobs)
bobs)]
[result (syntax-case-map
bases ()
[base (format-id #'base "~a~a~a"
(->unsyntax PREFIX)
(syntax-e #'base)
(string-append (format "~a" (->unsyntax SUFFIX)) ...))])])
(if got-single? (car result) result)))
(define-macro (suffix-id BASE-OR-BASES SUFFIX ...)
#'(infix-id "" BASE-OR-BASES SUFFIX ...))
(define-macro-cases syntax-property*
[(_ STX 'PROP0) ; read one
#'(syntax-property STX 'PROP0)]
[(_ STX 'PROP0 'PROP ...) ; read multiple
#'(cons (syntax-property* STX 'PROP0)
(let ([result (syntax-property* STX 'PROP ...)])
(if (pair? result)
result
(list result))))]
[(_ STX ['PROP0 VAL0 . PRESERVED0]) ; write one
#'(syntax-property STX 'PROP0 VAL0 . PRESERVED0)]
[(_ STX ['PROP0 VAL0 . PRESERVED0] ['PROP VAL . PRESERVED] ...) ; write multiple
#'(syntax-property* (syntax-property STX 'PROP0 VAL0 . PRESERVED0) ['PROP VAL . PRESERVED] ...)])
(module+ test
(define x (syntax-property* #'foo ['bar #t] ['zam 'boni]))
(check-false (syntax-property* x 'foo))
(check-true (syntax-property* x 'bar))
(check-equal? (syntax-property* x 'foo 'bar 'zam) '(#f #t boni)))
#;(define-syntax syntax-variable (make-rename-transformer #'format-id))

10
beautiful-racket-lib/br/verbose-app.rkt
View File

@ -1,10 +0,0 @@
#lang br
(require (prefix-in br: (only-in br #%app)))
(provide #%app)
(define-macro (#%app APP ARG ...)
#'(let ()
(br:#%app displayln (br:#%app format "handling subexpressions in ~a" '(APP ARG ...)))
(define result (br:#%app APP ARG ...))
(br:#%app displayln (br:#%app format "evaluating ~a = ~a" '(APP ARG ...) result ))
result))

4
beautiful-racket-lib/info.rkt
View File

@ -2,7 +2,5 @@
(define collection 'multi)
(define version "0.01")
(define deps '("base"
"sugar"
"gui-lib"))
(define deps '("base" "sugar"))
(define build-deps '("racket-doc" "rackunit-lib" "scribble-lib"))

0
brag/LICENSE → beautiful-racket-ragg/LICENSE
View File

0
brag/README.md → beautiful-racket-ragg/README.md
View File

5
beautiful-racket-ragg/br/ragg.rkt Executable file
View File

@ -0,0 +1,5 @@
#lang racket/base
(module+ reader
(require "ragg/codegen/reader.rkt")
(provide (all-from-out "ragg/codegen/reader.rkt")))

0
brag/brag/Makefile → beautiful-racket-ragg/br/ragg/Makefile
View File

417
brag/brag/brag.scrbl → beautiful-racket-ragg/br/ragg/br-ragg.scrbl
View File

@ -3,8 +3,8 @@
racket/date
file/md5
(for-label racket
brag/support
brag/examples/nested-word-list
br/ragg/support
br/ragg/examples/nested-word-list
(only-in parser-tools/lex lexer-src-pos)
(only-in syntax/parse syntax-parse ~literal)))
@ -26,29 +26,32 @@
@title{brag: the Beautiful Racket AST Generator}
@author["Danny Yoo (95%)" "Matthew Butterick (5%)"]
@title{ragg: a Racket AST Generator Generator}
@author+email["Danny Yoo" "dyoo@hashcollision.org"]
@defmodulelang[brag]
@section{Quick start}
@section{Informal quickstart}
@(define my-eval (make-base-eval))
@(my-eval '(require brag/examples/nested-word-list
@(my-eval '(require br/ragg/examples/nested-word-list
racket/list
racket/match))
Suppose we're given the
Salutations! Let's consider the following scenario: say that we're given the
following string:
@racketblock["(radiant (humble))"]
How would we turn this string into a structured value? That is, how would we @emph{parse} it? (Let's also suppose we've never heard of @racket[read].)
@margin-note{(... and pretend that we don't already know about the built-in
@racket[read] function.)} How do we go about turning this kind of string into a
structured value? That is, how would we @emph{parse} it?
First, we need to consider the structure of the things we'd like to parse. The
string above looks like a nested list of words. Good start.
We need to first consider the shape of the things we'd like to parse. The
string above looks like a deeply nested list of words. How might we describe
this formally? A convenient notation to describe the shape of these things is
@link["http://en.wikipedia.org/wiki/Backus%E2%80%93Naur_Form"]{Backus-Naur
Form} (BNF). So let's try to notate the structure of nested word lists in BNF.
Second, how might we describe this formally — meaning, in a way that a computer could understand? A common notation to describe the structure of these things is @link["http://en.wikipedia.org/wiki/Backus%E2%80%93Naur_Form"]{Backus-Naur Form} (BNF). So let's try to notate the structure of nested word lists in BNF.
@nested[#:style 'code-inset]{
@verbatim{
@ -56,37 +59,48 @@ nested-word-list: WORD
| LEFT-PAREN nested-word-list* RIGHT-PAREN
}}
What we intend by this notation is this: @racket[nested-word-list] is either a @racket[WORD], or a parenthesized list of @racket[nested-word-list]s. We use the character @litchar{*} to represent zero or more repetitions of the previous thing. We treat the uppercased @racket[LEFT-PAREN], @racket[RIGHT-PAREN], and @racket[WORD] as placeholders for @emph{tokens} (a @tech{token} being the smallest meaningful item in the parsed string):
What we intend by this notation is this: @racket[nested-word-list] is either an
atomic @racket[WORD], or a parenthesized list of any number of
@racket[nested-word-list]s. We use the character @litchar{*} to represent zero
or more repetitions of the previous thing, and we treat the uppercased
@racket[LEFT-PAREN], @racket[RIGHT-PAREN], and @racket[WORD] as placeholders
for atomic @emph{tokens}.
@margin-note{See @secref{install-ragg} for instructions on installing
@tt{ragg.}}
Here are a few examples of tokens:
@interaction[#:eval my-eval
(require brag/support)
(require br/ragg/support)
(token 'LEFT-PAREN)
(token 'WORD "crunchy" #:span 7)
(token 'RIGHT-PAREN)]
This BNF description is also known as a @deftech{grammar}. Just as it does in a natural language like English or French, a grammar describes something in terms of what elements can fit where.
Have we made progress? We have a valid grammar. But we're still missing a @emph{parser}: a function that can use that description to make structures out of a sequence of tokens.
Have we made progress? At this point, we only have a BNF description in hand,
but we're still missing a @emph{parser}, something to take that description and
use it to make structures out of a sequence of tokens.
Meanwhile, it's clear that we don't yet have a valid program because there's no @litchar{#lang} line. Let's add one: put @litchar{#lang brag} at the top of the grammar, and save it as a file called @filepath{nested-word-list.rkt}.
It's clear that we don't yet have a program because there's no @litchar{#lang}
line. We should add one. Put @litchar{#lang br/ragg} at the top of the BNF
description, and save it as a file called @filepath{nested-word-list.rkt}.
@filebox["nested-word-list.rkt"]{
@verbatim{
#lang brag
#lang br/ragg
nested-word-list: WORD
| LEFT-PAREN nested-word-list* RIGHT-PAREN
}}
Now it's a proper program. But what does it do?
Now it is a proper program. But what does it do?
@interaction[#:eval my-eval
@eval:alts[(require "nested-word-list.rkt") (void)]
parse
]
It gives us a @racket[parse] function. Let's investigate what @racket[parse]
does. What happens if we pass it a sequence of tokens?
It gives us a @racket[parse] function. Let's investigate what @racket[parse]
does for us. What happens if we pass it a sequence of tokens?
@interaction[#:eval my-eval
(define a-parsed-value
@ -98,16 +112,15 @@ does. What happens if we pass it a sequence of tokens?
(token 'RIGHT-PAREN ")"))))
a-parsed-value]
Those who have messed around with macros will recognize this as a @seclink["stx-obj" #:doc '(lib "scribblings/guide/guide.scrbl")]{syntax object}.
Wait... that looks suspiciously like a syntax object!
@interaction[#:eval my-eval
(syntax->datum a-parsed-value)
]
That's @racket[(some [pig])], essentially.
What happens if we pass our @racket[parse] function a bigger source of tokens?
What happens if we pass it a more substantial source of tokens?
@interaction[#:eval my-eval
@code:comment{tokenize: string -> (sequenceof token-struct?)}
@code:comment{Generate tokens from a string:}
@ -122,12 +135,15 @@ What happens if we pass our @racket[parse] function a bigger source of tokens?
(token 'WORD str)])))
@code:comment{For example:}
(define token-source (tokenize "(welcome (to (((brag)) ())))"))
(define token-source (tokenize "(welcome (to (((ragg)) ())))"))
(define v (parse token-source))
(syntax->datum v)
]
Welcome to @tt{brag}.
Welcome to @tt{ragg}.
@ -137,44 +153,69 @@ Welcome to @tt{brag}.
@section{Introduction}
@tt{brag} is a parser generator designed to be easy
to use:
@tt{ragg} is a parsing framework for Racket with the design goal to be easy
to use. It includes the following features:
@itemize[
@item{It provides a @litchar{#lang} for writing BNF grammars.
A module written in @litchar{#lang brag} automatically generates a
parser. The output of this parser tries to follow
@item{It provides a @litchar{#lang} for writing extended BNF grammars.
A module written in @litchar{#lang br/ragg} automatically generates a
parser. The output of this parser tries to follow
@link["http://en.wikipedia.org/wiki/How_to_Design_Programs"]{HTDP}
guidelines. The structure of the grammar informs the structure of the
doctrine; the structure of the grammar informs the structure of the
Racket syntax objects it generates.}
@item{The language uses a few conventions to simplify the expression of
grammars. The first rule in the grammar is assumed to be the
starting production. Identifiers in @tt{UPPERCASE} are treated as
terminal tokens. All other identifiers are treated as nonterminals.}
grammars. The first rule in the grammar is automatically assumed to be the
starting production. Identifiers in uppercase are assumed to represent
terminal tokens, and are otherwise the names of nonterminals.}
@item{Tokenizers can be developed independently of parsers.
@tt{brag} takes a liberal view on tokens: they can be strings,
symbols, or instances constructed with @racket[token]. Tokens can optionally provide source location, in which case a syntax object generated by the parser will too.}
@item{Tokenizers can be developed completely independently of parsers.
@tt{ragg} takes a liberal view on tokens: they can be strings,
symbols, or instances constructed with @racket[token]. Furthermore,
tokens can optionally provide location: if tokens provide location, the
generated syntax objects will as well.}
@item{The parser can usually handle ambiguous grammars.}
@item{The underlying parser should be able to handle ambiguous grammars.}
@item{It integrates with the rest of the Racket
@item{It should integrate with the rest of the Racket
@link["http://docs.racket-lang.org/guide/languages.html"]{language toolchain}.}
]
@subsection[#:tag "install-ragg"]{Installation}
@itemize[
@item{@margin-note{At the time of this writing, Racket 5.3.2 is in
@link["http://pre.racket-lang.org/"]{pre-release}.} If you are using a version
of Racket > 5.3.1, then follow the instructions on the
@link["https://plt-etc.byu.edu:9004/info/ragg"]{PLaneT2 page}.}
@item{For those who are using Racket <= 5.3.1, you can download the following PLT package:
@nested[#:style 'inset]{@link["ragg.plt"]{ragg.plt} [md5sum: @compute-md5sum["ragg.plt" "ab79038b40e510a5cf13363825c4aef4"]]
Last updated: @lookup-date["ragg.plt" "Wednesday, January 16th, 2013"]
}
Once downloaded, either use DrRacket's package installation features
(@link["http://docs.racket-lang.org/drracket/Menus.html#(idx._(gentag._57._(lib._scribblings/drracket/drracket..scrbl)))"]{Install
PLT File...} under DrRacket's File menu), or use the command line:
@nested[#:style 'inset]{@tt{raco setup -A ragg.plt}}}
]
@subsection{Example: a small DSL for ASCII diagrams}
@margin-note{This example is
@link["http://stackoverflow.com/questions/12345647/rewrite-this-script-by-designing-an-interpreter-in-racket"]{derived from a question} on Stack Overflow.}
To understand @tt{brag}'s design, let's look
at a toy problem. We'd like to define a language for
drawing simple ASCII diagrams. So if we write something like this:
@margin-note{This is a
@link["http://stackoverflow.com/questions/12345647/rewrite-this-script-by-designing-an-interpreter-in-racket"]{restatement
of a question on Stack Overflow}.} To motivate @tt{ragg}'s design, let's look
at the following toy problem: we'd like to define a language for
drawing simple ASCII diagrams. We'd like to be able write something like this:
@nested[#:style 'inset]{
@verbatim|{
@ -183,7 +224,7 @@ drawing simple ASCII diagrams. So if we write something like this:
3 9 X;
}|}
It should generate the following picture:
whose interpretation should generate the following picture:
@nested[#:style 'inset]{
@verbatim|{
@ -204,10 +245,10 @@ XXXXXXXXX
@subsection{Syntax and semantics}
We're being somewhat casual with what we mean by the program above. Let's try to nail down some meanings.
Each line of the program has a semicolon at the end, and describes the output of several @emph{rows} of the line drawing. Let's look at two of the lines in the example:
We're being very fast-and-loose with what we mean by the program above, so
let's try to nail down some meanings. Each line of the program has a semicolon
at the end, and describes the output of several @emph{rows} of the line
drawing. Let's look at two of the lines in the example:
@itemize[
@item{@litchar{3 9 X;}: ``Repeat the following 3 times: print @racket["X"] nine times, followed by
@ -218,17 +259,24 @@ followed by @racket["X"] three times, followed by @racket[" "] three times, foll
]
Then each line consists of a @emph{repeat} number, followed by pairs of
(number, character) @emph{chunks}. We'll assume here that the intent of the lowercased character @litchar{b} is to represent the printing of a 1-character whitespace @racket[" "], and for other uppercase letters to represent the printing of themselves.
(number, character) @emph{chunks}. We will
assume here that the intent of the lowercased character @litchar{b} is to
represent the printing of a 1-character whitespace @racket[" "], and for other
uppercase letters to represent the printing of themselves.
By understanding the pieces of each line, we can more easily capture that meaning in a grammar. Once we have each instruction of our ASCII DSL in a structured format, we should be able to parse it.
Once we have a better idea of the pieces of each line, we have a better chance
to capture that meaning in a formal notation. Once we have each instruction in
a structured format, we should be able to interpret it with a straighforward
case analysis.
Here is a first pass at expressing the structure of these line-drawing
programs.
Here's a first pass at expressing the structure of these line-drawing programs.
@subsection{Parsing the concrete syntax}
@filebox["simple-line-drawing.rkt"]{
@verbatim|{
#lang brag
#lang br/ragg
drawing: rows*
rows: repeat chunk+ ";"
repeat: INTEGER
@ -236,21 +284,21 @@ chunk: INTEGER STRING
}|
}
@margin-note{@secref{brag-syntax} describes @tt{brag}'s syntax in more detail.}
We write a @tt{brag} program as an BNF grammar, where patterns can be:
@margin-note{@secref{ragg-syntax} describes @tt{ragg}'s syntax in more detail.}
We write a @tt{ragg} program as an extended BNF grammar, where patterns can be:
@itemize[
@item{the names of other rules (e.g. @racket[chunk])}
@item{literal and symbolic token names (e.g. @racket[";"], @racket[INTEGER])}
@item{quantified patterns (e.g. @litchar{+} to represent one-or-more repetitions)}
]
The result of a @tt{brag} program is a module with a @racket[parse] function
The result of a @tt{ragg} program is a module with a @racket[parse] function
that can parse tokens and produce a syntax object as a result.
Let's exercise this function:
@interaction[#:eval my-eval
(require brag/support)
(require br/ragg/support)
@eval:alts[(require "simple-line-drawing.rkt")
(require brag/examples/simple-line-drawing)]
(require br/ragg/examples/simple-line-drawing)]
(define stx
(parse (list (token 'INTEGER 6)
(token 'INTEGER 2)
@ -261,11 +309,17 @@ Let's exercise this function:
(syntax->datum stx)
]
A @emph{token} is the smallest meaningful element of a source program. Tokens can be strings, symbols, or instances of the @racket[token] data structure. (Plus a few other special cases, which we'll discuss later.) Usually, a token holds a single character from the source program. But sometimes it makes sense to package a sequence of characters into a single token, if the sequence has an indivisible meaning.
Tokens can either be: plain strings, symbols, or instances produced by the
@racket[token] function. (Plus a few more special cases, one in which we'll describe in a
moment.)
If possible, we also want to attach source location information to each token. Why? Because this informatino will be incorporated into the syntax objects produced by @racket[parse].
Preferably, we want to attach each token with auxiliary source location
information. The more source location we can provide, the better, as the
syntax objects produced by @racket[parse] will incorporate them.
A parser often works in conjunction with a helper function called a @emph{lexer} that converts the raw code of the source program into tokens. The @racketmodname[parser-tools/lex] library can help us write a position-sensitive
Let's write a helper function, a @emph{lexer}, to help us construct tokens more
easily. The Racket standard library comes with a module called
@racketmodname[parser-tools/lex] which can help us write a position-sensitive
tokenizer:
@interaction[#:eval my-eval
@ -301,19 +355,24 @@ tokenizer:
]
Note also from this lexer example:
There are a few things to note from this lexer example:
@itemize[
@item{@racket[parse] accepts as input either a sequence of tokens, or a
function that produces tokens (which @racket[parse] will call repeatedly to get the next token).}
@item{The @racket[parse] function can consume either sequences of tokens, or a
function that produces tokens. Both of these are considered sources of
tokens.}
@item{As an alternative to the basic @racket[token] structure, a token can also be an instance of the @racket[position-token] structure (also found in @racketmodname[parser-tools/lex]). In that case, the token will try to derive its position from that of the position-token.}
@item{As a special case for acceptable tokens, a token can also be an instance
of the @racket[position-token] structure of @racketmodname[parser-tools/lex],
in which case the token will try to derive its position from that of the
position-token.}
@item{@racket[parse] will stop if it gets @racket[void] (or @racket['eof]) as a token.}
@item{The @racket[parse] function will stop reading from a token source if any
token is @racket[void].}
@item{@racket[parse] will skip any token that has
@racket[#:skip?] attribute set to @racket[#t]. For instance, tokens representing comments often use @racket[#:skip?].}
@item{The @racket[parse] function will skip over any token with the
@racket[#:skip?] attribute. Elements such as whitespace and comments will
often have @racket[#:skip?] set to @racket[#t].}
]
@ -321,16 +380,16 @@ function that produces tokens (which @racket[parse] will call repeatedly to get
@subsection{From parsing to interpretation}
We now have a parser for programs written in this simple-line-drawing language.
Our parser will return syntax objects:
Our parser will give us back syntax objects:
@interaction[#:eval my-eval
(define parsed-program
(parse (tokenize (open-input-string "3 9 X; 6 3 b 3 X 3 b; 3 9 X;"))))
(syntax->datum parsed-program)
]
Better still, these syntax objects will have a predictable
structure that follows the grammar:
Moreover, we know that these syntax objects have a regular, predictable
structure. Their structure follows the grammar, so we know we'll be looking at
values of the form:
@racketblock[
(drawing (rows (repeat <number>)
@ -342,14 +401,15 @@ where @racket[drawing], @racket[rows], @racket[repeat], and @racket[chunk]
should be treated literally, and everything else will be numbers or strings.
Still, these syntax-object values are just inert structures. How do we
interpret them, and make them @emph{print}? We claimed at the beginning of
this section that these syntax objects should be easy to interpret. So let's do it.
Still, these syntax object values are just inert structures. How do we
interpret them, and make them @emph{print}? We did claim at the beginning of
this section that these syntax objects should be fairly easy to case-analyze
and interpret, so let's do it.
@margin-note{This is a very quick-and-dirty treatment of @racket[syntax-parse].
See the @racketmodname[syntax/parse] documentation for a gentler guide to its
features.} Racket provides a special form called @racket[syntax-parse] in the
@racketmodname[syntax/parse] library. @racket[syntax-parse] lets us do a
@racketmodname[syntax/parse] library. @racket[syntax-parse] lets us do a
structural case-analysis on syntax objects: we provide it a set of patterns to
parse and actions to perform when those patterns match.
@ -372,7 +432,7 @@ says @racket[#t] if it's the literal @racket[yes], and @racket[#f] otherwise:
]
Here, we use @racket[~literal] to let @racket[syntax-parse] know that
@racket[yes] should show up literally in the syntax object. The patterns can
@racket[yes] should show up literally in the syntax object. The patterns can
also have some structure to them, such as:
@racketblock[({~literal drawing} rows-stxs ...)]
which matches on syntax objects that begin, literally, with @racket[drawing],
@ -416,11 +476,11 @@ Let's define @racket[interpret-rows] now:
(newline))]))]
For a @racket[rows], we extract out the @racket[repeat-number] out of the
syntax object and use it as the range of the @racket[for] loop. The inner loop
syntax object and use it as the range of the @racket[for] loop. The inner loop
walks across each @racket[chunk-stx] and calls @racket[interpret-chunk] on it.
Finally, we need to write a definition for @racket[interpret-chunk]. We want
Finally, we need to write a definition for @racket[interpret-chunk]. We want
it to extract out the @racket[chunk-size] and @racket[chunk-string] portions,
and print to standard output:
@ -493,7 +553,7 @@ Let's add one.
@filebox["letter-i.rkt"]{
@verbatim|{
#lang brag/examples/simple-line-drawing
#lang br/ragg/examples/simple-line-drawing
3 9 X;
6 3 b 3 X 3 b;
3 9 X;
@ -504,14 +564,14 @@ Now @filepath{letter-i.rkt} is a program.
How does this work? From the previous sections, we've seen how to take the
contents of a file and interpret it. What we want to do now is teach Racket
how to compile programs labeled with this @litchar{#lang} line. We'll do two
contents of a file and interpret it. What we want to do now is teach Racket
how to compile programs labeled with this @litchar{#lang} line. We'll do two
things:
@itemize[
@item{Tell Racket to use the @tt{brag}-generated parser and lexer we defined
@item{Tell Racket to use the @tt{ragg}-generated parser and lexer we defined
earlier whenever it sees a program written with
@litchar{#lang brag/examples/simple-line-drawing}.}
@litchar{#lang br/ragg/examples/simple-line-drawing}.}
@item{Define transformation rules for @racket[drawing], @racket[rows], and
@racket[chunk] to rewrite these into standard Racket forms.}
@ -519,30 +579,30 @@ earlier whenever it sees a program written with
The second part, the writing of the transformation rules, will look very
similar to the definitions we wrote for the interpreter, but the transformation
will happen at compile-time. (We @emph{could} just resort to simply calling
will happen at compile-time. (We @emph{could} just resort to simply calling
into the interpreter we just wrote up, but this section is meant to show that
compilation is also viable.)
We do the first part by defining a @emph{module reader}: a
@link["http://docs.racket-lang.org/guide/syntax_module-reader.html"]{module
reader} tells Racket how to parse and compile a file. Whenever Racket sees a
reader} tells Racket how to parse and compile a file. Whenever Racket sees a
@litchar{#lang <name>}, it looks for a corresponding module reader in
@filepath{<name>/lang/reader}.
Here's the definition for
@filepath{brag/examples/simple-line-drawing/lang/reader.rkt}:
@filepath{br/ragg/examples/simple-line-drawing/lang/reader.rkt}:
@filebox["brag/examples/simple-line-drawing/lang/reader.rkt"]{
@filebox["br/ragg/examples/simple-line-drawing/lang/reader.rkt"]{
@codeblock|{
#lang s-exp syntax/module-reader
brag/examples/simple-line-drawing/semantics
br/ragg/examples/simple-line-drawing/semantics
#:read my-read
#:read-syntax my-read-syntax
#:whole-body-readers? #t
(require brag/examples/simple-line-drawing/lexer
brag/examples/simple-line-drawing/grammar)
(require br/ragg/examples/simple-line-drawing/lexer
br/ragg/examples/simple-line-drawing/grammar)
(define (my-read in)
(syntax->datum (my-read-syntax #f in)))
@ -553,8 +613,12 @@ brag/examples/simple-line-drawing/semantics
}
We use a helper module @racketmodname[syntax/module-reader], which provides
utilities for creating a module reader. It uses the lexer and
@tt{brag}-generated parser we defined earlier, and also tells Racket that it should compile the forms in the syntax
utilities for creating a module reader. It uses the lexer and
@tt{ragg}-generated parser we defined earlier (saved into
@link["http://hashcollision.org/ragg/examples/simple-line-drawing/lexer.rkt"]{lexer.rkt}
and
@link["http://hashcollision.org/ragg/examples/simple-line-drawing/grammar.rkt"]{grammar.rkt}
modules), and also tells Racket that it should compile the forms in the syntax
object using a module called @filepath{semantics.rkt}.
@margin-note{For a systematic treatment on capturing the semantics of
@ -563,7 +627,7 @@ Interpretation}.}
Let's look into @filepath{semantics.rkt} and see what's involved in
compilation:
@filebox["brag/examples/simple-line-drawing/semantics.rkt"]{
@filebox["br/ragg/examples/simple-line-drawing/semantics.rkt"]{
@codeblock|{
#lang racket/base
(require (for-syntax racket/base syntax/parse))
@ -619,7 +683,7 @@ compilation:
The semantics hold definitions for @racket[compile-drawing],
@racket[compile-rows], and @racket[compile-chunk], similar to what we had for
interpretation with @racket[interpret-drawing], @racket[interpret-rows], and
@racket[interpret-chunk]. However, compilation is not the same as
@racket[interpret-chunk]. However, compilation is not the same as
interpretation: each definition does not immediately execute the act of
drawing, but rather returns a syntax object whose evaluation will do the actual
work.
@ -628,22 +692,22 @@ There are a few things to note:
@itemize[
@item{@tt{brag}'s native data structure is the syntax object because the
@item{@tt{ragg}'s native data structure is the syntax object because the
majority of Racket's language-processing infrastructure knows how to read and
write this structured value.}
@item{
@margin-note{By the way, we can just as easily rewrite the semantics so that
@racket[compile-rows] does explicitly call @racket[compile-chunk]. Often,
@racket[compile-rows] does explicitly call @racket[compile-chunk]. Often,
though, it's easier to write the transformation functions in this piecemeal way
and depend on the Racket macro expansion system to do the rewriting as it
encounters each of the forms.}
Unlike in interpretation, @racket[compile-rows] doesn't
compile each chunk by directly calling @racket[compile-chunk]. Rather, it
compile each chunk by directly calling @racket[compile-chunk]. Rather, it
depends on the Racket macro expander to call each @racket[compile-XXX] function
as it encounters a @racket[drawing], @racket[rows], or @racket[chunk] in the
parsed value. The three statements at the bottom of @filepath{semantics.rkt} inform
parsed value. The three statements at the bottom of @filepath{semantics.rkt} inform
the macro expansion system to do this:
@racketblock[
@ -654,12 +718,12 @@ the macro expansion system to do this:
]
Altogether, @tt{brag}'s intent is to be a parser generator generator for Racket
that's easy and fun to use. It's meant to fit naturally with the other tools
in the Racket language toolchain. Hopefully, it will reduce the friction in
Altogether, @tt{ragg}'s intent is to be a parser generator generator for Racket
that's easy and fun to use. It's meant to fit naturally with the other tools
in the Racket language toolchain. Hopefully, it will reduce the friction in
making new languages with alternative concrete syntaxes.
The rest of this document describes the @tt{brag} language and the parsers it
The rest of this document describes the @tt{ragg} language and the parsers it
generates.
@ -668,9 +732,9 @@ generates.
@section{The language}
@subsection[#:tag "brag-syntax"]{Syntax and terminology}
A program in the @tt{brag} language consists of the language line
@litchar{#lang brag}, followed by a collection of @tech{rule}s and
@subsection[#:tag "ragg-syntax"]{Syntax and terminology}
A program in the @tt{ragg} language consists of the language line
@litchar{#lang br/ragg}, followed by a collection of @tech{rule}s and
@tech{line comment}s.
A @deftech{rule} is a sequence consisting of: a @tech{rule identifier}, a colon
@ -681,7 +745,7 @@ A @deftech{rule identifier} is an @tech{identifier} that is not in upper case.
A @deftech{token identifier} is an @tech{identifier} that is in upper case.
An @deftech{identifier} is a character sequence of letters, numbers, and
characters in @racket["-.!$%&/<=>?^_~@"]. It must not contain
characters in @racket["-.!$%&/<=>?^_~@"]. It must not contain
@litchar{*} or @litchar{+}, as those characters are used to denote
quantification.
@ -703,7 +767,7 @@ continues till the end of the line.
For example, in the following program:
@nested[#:style 'inset
@verbatim|{
#lang brag
#lang br/ragg
;; A parser for a silly language
sentence: verb optional-adjective object
verb: greeting
@ -713,9 +777,9 @@ object: "world" | WORLD
}|]
the elements @tt{sentence}, @tt{verb}, @tt{greeting}, and @tt{object} are rule
identifiers. The first rule, @litchar{sentence: verb optional-adjective
identifiers. The first rule, @litchar{sentence: verb optional-adjective
object}, is a rule whose right side is an implicit pattern sequence of three
sub-patterns. The uppercased @tt{WORLD} is a token identifier. The fourth rule in the program associates @tt{greeting} with a @tech{choice pattern}.
sub-patterns. The uppercased @tt{WORLD} is a token identifier. The fourth rule in the program associates @tt{greeting} with a @tech{choice pattern}.
@ -723,20 +787,20 @@ More examples:
@itemize[
@item{A
BNF for binary
@link["http://hashcollision.org/ragg/examples/01-equal.rkt"]{BNF} for binary
strings that contain an equal number of zeros and ones.
@verbatim|{
#lang brag
#lang br/ragg
equal: [zero one | one zero] ;; equal number of "0"s and "1"s.
zero: "0" equal | equal "0" ;; has an extra "0" in it.
one: "1" equal | equal "1" ;; has an extra "1" in it.
}|
}
@item{A BNF for
@item{A @link["http://hashcollision.org/ragg/examples/baby-json.rkt"]{BNF} for
@link["http://www.json.org/"]{JSON}-like structures.
@verbatim|{
#lang brag
#lang br/ragg
json: number | string
| array | object
number: NUMBER
@ -748,26 +812,30 @@ kvpair: ID ":" json
}
]
The @link["https://github.com/dyoo/ragg"]{ragg github source repository}
includes
@link["https://github.com/dyoo/ragg/tree/master/ragg/examples"]{several more
examples}.
@subsection{Syntax errors}
Besides the basic syntax errors that can occur with a malformed grammar, there
are a few other classes of situations that @litchar{#lang brag} will consider
are a few other classes of situations that @litchar{#lang br/ragg} will consider
as syntax errors.
@tt{brag} will raise a syntax error if the grammar:
@tt{ragg} will raise a syntax error if the grammar:
@itemize[
@item{doesn't have any rules.}
@item{has a rule with the same left hand side as any other rule.}
@item{refers to rules that have not been defined. e.g. the
@item{refers to rules that have not been defined. e.g. the
following program:
@nested[#:style 'code-inset
@verbatim|{
#lang brag
#lang br/ragg
foo: [bar]
}|
]
@ -776,14 +844,14 @@ should raise an error because @tt{bar} has not been defined, even though
@item{uses the token name @racket[EOF]; the end-of-file token type is reserved
for internal use by @tt{brag}.}
for internal use by @tt{ragg}.}
@item{contains a rule that has no finite derivation. e.g. the following
@item{contains a rule that has no finite derivation. e.g. the following
program:
@nested[#:style 'code-inset
@verbatim|{
#lang brag
#lang br/ragg
infinite-a: "a" infinite-a
}|
]
@ -792,14 +860,14 @@ should raise an error because no finite sequence of tokens will satisfy
]
Otherwise, @tt{brag} should be fairly tolerant and permit even ambiguous
Otherwise, @tt{ragg} should be fairly tolerant and permit even ambiguous
grammars.
@subsection{Semantics}
@declare-exporting[brag/examples/nested-word-list]
@declare-exporting[br/ragg/examples/nested-word-list]
A program written in @litchar{#lang brag} produces a module that provides a few
bindings. The most important of these is @racket[parse]:
A program written in @litchar{#lang br/ragg} produces a module that provides a few
bindings. The most important of these is @racket[parse]:
@defproc[(parse [source any/c #f]
[token-source (or/c (sequenceof token)
@ -807,13 +875,13 @@ bindings. The most important of these is @racket[parse]:
syntax?]{
Parses the sequence of @tech{tokens} according to the rules in the grammar, using the
first rule as the start production. The parse must completely consume
first rule as the start production. The parse must completely consume
@racket[token-source].
The @deftech{token source} can either be a sequence, or a 0-arity function that
produces @tech{tokens}.
A @deftech{token} in @tt{brag} can be any of the following values:
A @deftech{token} in @tt{ragg} can be any of the following values:
@itemize[
@item{a string}
@item{a symbol}
@ -827,9 +895,9 @@ A token whose type is either @racket[void] or @racket['EOF] terminates the
source.
If @racket[parse] succeeds, it will return a structured syntax object. The
If @racket[parse] succeeds, it will return a structured syntax object. The
structure of the syntax object follows the overall structure of the rules in
the BNF grammar. For each rule @racket[r] and its associated pattern @racket[p],
the BNF. For each rule @racket[r] and its associated pattern @racket[p],
@racket[parse] generates a syntax object @racket[#'(r p-value)] where
@racket[p-value]'s structure follows a case analysis on @racket[p]:
@ -848,7 +916,7 @@ pattern that informs the parser to introduces nested structure into the syntax
object.
If the grammar has ambiguity, @tt{brag} will choose and return a parse, though
If the grammar has ambiguity, @tt{ragg} will choose and return a parse, though
it does not guarantee which one it chooses.
@ -859,7 +927,7 @@ If the parse cannot be performed successfully, or if a token in the
It's often convenient to extract a parser for other non-terminal rules in the
grammar, and not just for the first rule. A @tt{brag}-generated module also
grammar, and not just for the first rule. A @tt{ragg}-generated module also
provides a form called @racket[make-rule-parser] to extract a parser for the
other non-terminals:
@ -868,11 +936,11 @@ other non-terminals:
Constructs a parser for the @racket[name] of one of the non-terminals
in the grammar.
For example, given the @tt{brag} program
For example, given the @tt{ragg} program
@filepath{simple-arithmetic-grammar.rkt}:
@filebox["simple-arithmetic-grammar.rkt"]{
@verbatim|{
#lang brag
#lang br/ragg
expr : term ('+' term)*
term : factor ('*' factor)*
factor : INT
@ -881,7 +949,7 @@ factor : INT
the following interaction shows how to extract a parser for @racket[term]s.
@interaction[#:eval my-eval
@eval:alts[(require "simple-arithmetic-grammar.rkt")
(require brag/examples/simple-arithmetic-grammar)]
(require br/ragg/examples/simple-arithmetic-grammar)]
(define term-parse (make-rule-parser term))
(define tokens (list (token 'INT 3)
"*"
@ -909,7 +977,7 @@ A set of all the token types used in a grammar.
For example:
@interaction[#:eval my-eval
@eval:alts[(require "simple-arithmetic-grammar.rkt")
(require brag/examples/simple-arithmetic-grammar)]
(require br/ragg/examples/simple-arithmetic-grammar)]
all-token-types
]
@ -921,10 +989,10 @@ all-token-types
@section{Support API}
@defmodule[brag/support]
@defmodule[br/ragg/support]
The @racketmodname[brag/support] module provides functions to interact with
@tt{brag} programs. The most useful is the @racket[token] function, which
The @racketmodname[br/ragg/support] module provides functions to interact with
@tt{ragg} programs. The most useful is the @racket[token] function, which
produces tokens to be parsed.
@defproc[(token [type (or/c string? symbol?)]
@ -975,4 +1043,65 @@ DrRacket should highlight the offending locations in the source.}
@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@section{Caveats and things to do}
Here are a few caveats and future aims for @tt{ragg}.
@itemize[
@item{@tt{ragg} doesn't currently have a good story about operator precedence.
Future versions of @tt{ragg} will support the specification of operator
precedence to deal with grammar ambiguity, probably by extending the BNF
grammar rules in @litchar{#lang br/ragg} with keyword arguments.}
@item{I currently depend on the lexer framework provided by
@racketmodname[parser-tools/lex], which has a steeper learning curve than I'd
like. A future version of @tt{ragg} will probably try to provide a nicer set
of tools for defining lexers.}
@item{The underlying parsing engine (an Earley-style parser) has not been fully
optimized, so it may exhibit degenerate parse times. A future version of
@tt{ragg} will guarantee @math{O(n^3)} time bounds so that at the very least,
parses will be polynomial-time.}
@item{@tt{ragg} doesn't yet have a good story on dealing with parser error
recovery. If a parse fails, it tries to provide the source location, but does
little else.}
@item{@tt{ragg} is slightly misnamed: what it really builds is a concrete
syntax tree rather than an abstract syntax tree. A future version of @tt{ragg}
will probably support annotations on patterns so that they can be omitted or
transformed in the parser output.}
]
@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@section{Miscellaneous and thanks}
Thanks to Matthew Flatt for pointing me to @racket[cfg-parser] from the
@racket[cfg-parser] library. Joe Politz gave me good advice and
feedback. Also, he suggested the name ``ragg''. Other alternatives I'd been
considering were ``autogrammar'' or ``chompy''. Thankfully, he is a better
Namer than me. Daniel Patterson provided feedback that led to
@racket[make-rule-parser]. Robby Findler and Guillaume Marceau provided
steadfast suggestions to look into other parsing frameworks like
@link["http://en.wikipedia.org/wiki/Syntax_Definition_Formalism"]{SDF} and
@link["http://sablecc.org/"]{SableCC}. Special thanks to Shriram
Krishnamurthi, who convinced me that other people might find this package
useful.
@close-eval[my-eval]

0
brag/brag/cfg-parser/cfg-parser.rkt → beautiful-racket-ragg/br/ragg/cfg-parser/cfg-parser.rkt
View File

206
brag/brag/codegen/codegen.rkt → beautiful-racket-ragg/br/ragg/codegen/codegen.rkt
View File

@ -5,11 +5,11 @@
racket/set
racket/syntax
syntax/srcloc
brag/rules/stx-types
br/ragg/rules/stx-types
"flatten.rkt"
syntax/id-table
(prefix-in sat: "satisfaction.rkt")
(prefix-in support: brag/support)
(prefix-in support: br/ragg/support)
(prefix-in stxparse: syntax/parse))
(provide rules-codegen)
@ -26,12 +26,12 @@
(begin
;; (listof stx)
(define rules (syntax->list #'(r ...)))
(when (empty? rules)
(raise-syntax-error 'brag
(raise-syntax-error 'ragg
(format "The grammar does not appear to have any rules")
stx))
(check-all-rules-defined! rules)
(check-all-rules-no-duplicates! rules)
(check-all-rules-satisfiable! rules)
@ -39,28 +39,28 @@
;; We flatten the rules so we can use the yacc-style ruleset that parser-tools
;; supports.
(define flattened-rules (flatten-rules rules))
(define generated-rule-codes (map flat-rule->yacc-rule flattened-rules))
;; The first rule, by default, is the start rule.
(define rule-ids (for/list ([a-rule (in-list rules)])
(rule-id a-rule)))
(rule-id a-rule)))
(define start-id (first rule-ids))
(define-values (implicit-tokens ;; (listof identifier)
explicit-tokens) ;; (listof identifier)
(rules-collect-token-types rules))
;; (listof symbol)
(define implicit-token-types
(map string->symbol
(set->list (list->set (map syntax-e implicit-tokens)))))
;; (listof symbol)
(define explicit-token-types
(set->list (list->set (map syntax-e explicit-tokens))))
;; (listof symbol)
(define token-types
(set->list (list->set (append (map (lambda (x) (string->symbol (syntax-e x)))
@ -68,13 +68,13 @@
(map syntax-e explicit-tokens)))))
(with-syntax ([start-id start-id]
[(token-type ...) token-types]
[(token-type-constructor ...)
(map (lambda (x) (string->symbol (format "token-~a" x)))
token-types)]
[(explicit-token-types ...) explicit-token-types]
[(implicit-token-types ...) implicit-token-types]
[(implicit-token-types-str ...) (map symbol->string implicit-token-types)]
@ -88,9 +88,9 @@
(begin
(require parser-tools/lex
parser-module
brag/codegen/runtime
brag/support
brag/private/internal-support
br/ragg/codegen/runtime
br/ragg/support
br/ragg/private/internal-support
racket/set
(for-syntax syntax/parse racket/base))
@ -102,27 +102,27 @@
#;current-tokenizer-error-handler
#;[struct-out exn:fail:parsing]
)
(define-tokens enumerated-tokens (token-type ...))
;; all-token-types lists all the tokens (except for EOF)
(define all-token-types
(set-remove (set 'token-type ...) 'EOF))
;; For internal use by the permissive tokenizer only:
(define all-tokens-hash/mutable
(make-hash (list ;; Note: we also allow the eof object here, to make
;; the permissive tokenizer even nicer to work with.
(cons eof token-EOF)
(cons 'token-type token-type-constructor) ...)))
;; the permissive tokenizer even nicer to work with.
(cons eof token-EOF)
(cons 'token-type token-type-constructor) ...)))
#;(define default-lex/1
(lexer-src-pos [implicit-token-types-str
(token 'implicit-token-types lexeme)]
...
[(eof) (token eof)]))
(define-syntax (make-rule-parser stx-2)
(syntax-parse stx-2
[(_ start-rule:id)
@ -152,14 +152,7 @@
(parameterize ([current-source source])
(parse tokenizer))])))]))
(define parse (make-rule-parser start-id))
(provide parse-tree)
(define (parse-tree x)
(let loop ([x (syntax->datum (parse x))])
(cond
[(list? x) (map loop x)]
[(char? x) (format "~a" x)]
[else x])))))))]))
(define parse (make-rule-parser start-id))))))]))
;; Given a flattened rule, returns a syntax for the code that
@ -179,8 +172,11 @@
(with-syntax ([(translated-clause ...) translated-clauses])
#`[name translated-clause ...]))]))
#|
MB: This function generates the input for the parse tree,
passing it to the two functions in "runtime.rkt".
|#
(require (only-in sugar/debug report report*))
;; translates a single primitive rule clause.
;; A clause is a simple list of ids, lit, vals, and inferred-id elements.
;; The action taken depends on the pattern type.
@ -188,51 +184,45 @@
(define translated-patterns
(let loop ([primitive-patterns (syntax->list a-clause)])
(cond
[(empty? primitive-patterns)
'()]
[else
(cons (syntax-case (first primitive-patterns) (id lit token inferred-id)
[(id val)
#'val]
[(lit val)
(datum->syntax #f (string->symbol (syntax-e #'val)) #'val)]
[(token val)
#'val]
[(inferred-id val reason)
#'val])
(loop (rest primitive-patterns)))])))
[(empty? primitive-patterns)
'()]
[else
(cons (syntax-case (first primitive-patterns) (id lit token inferred-id)
[(id val)
#'val]
[(lit val)
(datum->syntax #f (string->symbol (syntax-e #'val)) #'val)]
[(token val)
#'val]
[(inferred-id val reason)
#'val])
(loop (rest primitive-patterns)))])))
(define translated-actions
(for/list ([translated-pattern (in-list translated-patterns)]
[primitive-pattern (syntax->list a-clause)]
[pos (in-naturals 1)])
(if (eq? (syntax-property primitive-pattern 'hide) 'hide)
#'null
(with-syntax ([$X
(format-id translated-pattern "$~a" pos)]
[$X-start-pos
(format-id translated-pattern "$~a-start-pos" pos)]
[$X-end-pos
(format-id translated-pattern "$~a-end-pos" pos)])
(syntax-case primitive-pattern (id lit token inferred-id)
;; When a rule usage is inferred, the value of $X is a syntax object
;; whose head is the name of the inferred rule . We strip that out,
;; leaving the residue to be absorbed.
[(inferred-id val reason)
#'(syntax-case $X ()
[(inferred-rule-name . rest)
(syntax->list #'rest)])]
[(id val)
;; at this point, the 'hide property is either #f or "splice"
;; ('hide value is handled at the top of this conditional
;; we need to use boolean because a symbol is treated as an identifier.
;; also we'll separate it into its own property for clarity and test for it in "runtime.rkt"
#`(list (syntax-property $X 'splice-rh-id #,(and (syntax-property primitive-pattern 'hide) #t)))]
[(lit val)
#'(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))]
[(token val)
#'(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))])))))
(with-syntax ([$X
(format-id translated-pattern "$~a" pos)]
[$X-start-pos
(format-id translated-pattern "$~a-start-pos" pos)]
[$X-end-pos
(format-id translated-pattern "$~a-end-pos" pos)])
(syntax-case primitive-pattern (id lit token inferred-id)
;; When a rule usage is inferred, the value of $X is a syntax object
;; whose head is the name of the inferred rule . We strip that out,
;; leaving the residue to be absorbed.
[(inferred-id val reason)
(report* #'val #'reason)
#'(syntax-case $X ()
[(inferred-rule-name . rest)
(syntax->list #'rest)])]
[(id val)
#`(list $X)]
[(lit val)
#`(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))]
[(token val)
#`(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))]))))
(define whole-rule-loc
(if (empty? translated-patterns)
@ -240,14 +230,12 @@
(with-syntax ([$1-start-pos (datum->syntax (first translated-patterns) '$1-start-pos)]
[$n-end-pos (format-id (last translated-patterns) "$~a-end-pos" (length translated-patterns))])
#`(positions->srcloc $1-start-pos $n-end-pos))))
;; move 'hide-or-splice-lhs-id property into function because name is datum-ized
(with-syntax ([(translated-pattern ...) translated-patterns]
[(translated-action ...) translated-actions])
#`[(translated-pattern ...)
(rule-components->syntax '#,rule-name/false translated-action ...
#:srcloc #,whole-rule-loc
#:hide-or-splice? #,(syntax-property rule-name/false 'hide-or-splice-lhs-id))]))
#:srcloc #,whole-rule-loc)]))
@ -263,10 +251,10 @@
(define-values (implicit explicit)
(for/fold ([implicit '()]
[explicit (list (datum->syntax (first rules) 'EOF))])
([r (in-list rules)])
([r (in-list rules)])
(rule-collect-token-types r implicit explicit)))
(values (reverse implicit) (reverse explicit)))
(define (rule-collect-token-types a-rule implicit explicit)
(syntax-case a-rule (rule)
[(rule id a-pattern)
@ -306,12 +294,12 @@
;; rule-id: rule -> identifier-stx
;; Get the binding id of a rule.
(define (rule-id a-rule)
(syntax-case a-rule (rule)
(syntax-case a-rule (rule)
[(rule id a-pattern)
#'id]))
(define (rule-pattern a-rule)
(syntax-case a-rule (rule)
(syntax-case a-rule (rule)
[(rule id a-pattern)
#'a-pattern]))
@ -323,26 +311,26 @@
(define table (make-free-id-table))
;; Pass one: collect all the defined rule names.
(for ([a-rule (in-list rules)])
(free-id-table-set! table (rule-id a-rule) #t))
(free-id-table-set! table (rule-id a-rule) #t))
;; Pass two: check each referenced id, and make sure it's been defined.
(for ([a-rule (in-list rules)])
(for ([referenced-id (in-list (rule-collect-used-ids a-rule))])
(unless (free-id-table-ref table referenced-id (lambda () #f))
(raise-syntax-error #f (format "Rule ~a has no definition" (syntax-e referenced-id))
referenced-id)))))
(for ([referenced-id (in-list (rule-collect-used-ids a-rule))])
(unless (free-id-table-ref table referenced-id (lambda () #f))
(raise-syntax-error #f (format "Rule ~a has no definition" (syntax-e referenced-id))
referenced-id)))))
;; check-all-rules-no-duplicates!: (listof rule-stx) -> void
(define (check-all-rules-no-duplicates! rules)
(define table (make-free-id-table))
;; Pass one: collect all the defined rule names.
(for ([a-rule (in-list rules)])
(define maybe-other-rule-id (free-id-table-ref table (rule-id a-rule) (lambda () #f)))
(when maybe-other-rule-id
(raise-syntax-error #f (format "Rule ~a has a duplicate definition" (syntax-e (rule-id a-rule)))
(rule-id a-rule)
#f
(list (rule-id a-rule) maybe-other-rule-id)))
(free-id-table-set! table (rule-id a-rule) (rule-id a-rule))))
(define maybe-other-rule-id (free-id-table-ref table (rule-id a-rule) (lambda () #f)))
(when maybe-other-rule-id
(raise-syntax-error #f (format "Rule ~a has a duplicate definition" (syntax-e (rule-id a-rule)))
(rule-id a-rule)
#f
(list (rule-id a-rule) maybe-other-rule-id)))
(free-id-table-set! table (rule-id a-rule) (rule-id a-rule))))
@ -390,16 +378,16 @@
(define (check-all-rules-satisfiable! rules)
(define toplevel-rule-table (make-free-id-table))
(for ([a-rule (in-list rules)])
(free-id-table-set! toplevel-rule-table
(rule-id a-rule)
(sat:make-and)))
(free-id-table-set! toplevel-rule-table
(rule-id a-rule)
(sat:make-and)))
(define leaves '())
(define (make-leaf)
(define a-leaf (sat:make-and))
(set! leaves (cons a-leaf leaves))
a-leaf)
(define (process-pattern a-pattern)
(syntax-case a-pattern (id lit token choice repeat maybe seq)
[(id val)
@ -412,8 +400,8 @@
(begin
(define an-or-node (sat:make-or))
(for ([v (in-list (syntax->list #'(vals ...)))])
(define a-child (process-pattern v))
(sat:add-child! an-or-node a-child))
(define a-child (process-pattern v))
(sat:add-child! an-or-node a-child))
an-or-node)]
[(repeat min val)
(syntax-case #'min ()
@ -427,19 +415,19 @@
(begin
(define an-and-node (sat:make-and))
(for ([v (in-list (syntax->list #'(vals ...)))])
(define a-child (process-pattern v))
(sat:add-child! an-and-node a-child))
(define a-child (process-pattern v))
(sat:add-child! an-and-node a-child))
an-and-node)]))
(for ([a-rule (in-list rules)])
(define rule-node (free-id-table-ref toplevel-rule-table (rule-id a-rule)))
(sat:add-child! rule-node (process-pattern (rule-pattern a-rule))))
(define rule-node (free-id-table-ref toplevel-rule-table (rule-id a-rule)))
(sat:add-child! rule-node (process-pattern (rule-pattern a-rule))))
(for ([a-leaf leaves])
(sat:visit! a-leaf))
(sat:visit! a-leaf))
(for ([a-rule (in-list rules)])
(define rule-node (free-id-table-ref toplevel-rule-table (rule-id a-rule)))
(unless (sat:node-yes? rule-node)
(raise-syntax-error #f (format "Rule ~a has no finite derivation" (syntax-e (rule-id a-rule)))
(rule-id a-rule)))))
(define rule-node (free-id-table-ref toplevel-rule-table (rule-id a-rule)))
(unless (sat:node-yes? rule-node)
(raise-syntax-error #f (format "Rule ~a has no finite derivation" (syntax-e (rule-id a-rule)))
(rule-id a-rule)))))

2
brag/brag/codegen/flatten.rkt → beautiful-racket-ragg/br/ragg/codegen/flatten.rkt
View File

@ -1,5 +1,5 @@
#lang racket/base
(require brag/rules/stx-types
(require br/ragg/rules/stx-types
(for-syntax racket/base))
(provide flatten-rule

10
brag/brag/codegen/reader.rkt → beautiful-racket-ragg/br/ragg/codegen/reader.rkt
View File

@ -1,14 +1,14 @@
#lang s-exp syntax/module-reader
brag/codegen/sexp-based-lang
br/ragg/codegen/sexp-based-lang
#:read my-read
#:read-syntax my-read-syntax
#:info my-get-info
#:whole-body-readers? #t
(require brag/rules/parser
brag/rules/lexer
brag/rules/stx
brag/rules/rule-structs)
(require br/ragg/rules/parser
br/ragg/rules/lexer
br/ragg/rules/stx
br/ragg/rules/rule-structs)
(define (my-read in)
(syntax->datum (my-read-syntax #f in)))

174
beautiful-racket-ragg/br/ragg/codegen/runtime.rkt Executable file
View File

@ -0,0 +1,174 @@
#lang racket/base
(require racket/match
racket/list
racket/generator
(prefix-in lex: parser-tools/lex)
br/ragg/support
br/ragg/private/internal-support)
(provide THE-ERROR-HANDLER
make-permissive-tokenizer
atomic-datum->syntax
positions->srcloc
rule-components->syntax)
;; The level of indirection here is necessary since the yacc grammar wants a
;; function value for the error handler up front. We want to delay that decision
;; till parse time.
(define (THE-ERROR-HANDLER tok-ok? tok-name tok-value start-pos end-pos)
(match (positions->srcloc start-pos end-pos)
[(list src line col offset span)
((current-parser-error-handler) tok-name
tok-value
offset
line
col
span)]))
(define no-position (lex:position #f #f #f))
(define (no-position? p)
(not
(or (lex:position-line p)
(lex:position-col p)
(lex:position-offset p))))
;; make-permissive-tokenizer: (U (sequenceof (U token token-struct eof void)) (-> (U token token-struct eof void))) hash -> (-> position-token)
;; Creates a tokenizer from the given value.
;; FIXME: clean up code.
(define (make-permissive-tokenizer tokenizer token-type-hash)
(define tokenizer-thunk (cond
[(sequence? tokenizer)
(sequence->generator tokenizer)]
[(procedure? tokenizer)
tokenizer]))
;; lookup: symbol any pos pos -> position-token
(define (lookup type val start-pos end-pos)
(lex:position-token
((hash-ref token-type-hash type
(lambda ()
((current-tokenizer-error-handler) (format "~a" type) val
(lex:position-offset start-pos)
(lex:position-line start-pos)
(lex:position-col start-pos)
(and (number? (lex:position-offset start-pos))
(number? (lex:position-offset end-pos))
(- (lex:position-offset end-pos)
(lex:position-offset start-pos))))))
val)
start-pos end-pos))
(define (permissive-tokenizer)
(define next-token (tokenizer-thunk))
(let loop ([next-token next-token])
(match next-token
[(or (? eof-object?) (? void?))
(lookup 'EOF eof no-position no-position)]
[(? symbol?)
(lookup next-token next-token no-position no-position)]
[(? string?)
(lookup (string->symbol next-token) next-token no-position no-position)]
[(? char?)
(lookup (string->symbol (string next-token)) next-token no-position no-position)]
;; Compatibility
[(? lex:token?)
(loop (token (lex:token-name next-token)
(lex:token-value next-token)))]
[(token-struct type val offset line column span skip?)
(cond [skip?
;; skip whitespace, and just tokenize again.
(permissive-tokenizer)]
[(hash-has-key? token-type-hash type)
(define start-pos (lex:position offset line column))
;; try to synthesize a consistent end position.
(define end-pos (lex:position (if (and (number? offset) (number? span))
(+ offset span)
offset)
line
(if (and (number? column) (number? span))
(+ column span)
column)))
(lookup type val start-pos end-pos)]
[else
;; We ran into a token of unrecognized type. Let's raise an appropriate error.
((current-tokenizer-error-handler) type val
offset line column span)])]
[(lex:position-token t s e)
(define a-position-token (loop t))
(lex:position-token (lex:position-token-token a-position-token)
(if (no-position? (lex:position-token-start-pos a-position-token))
s
(lex:position-token-start-pos a-position-token))
(if (no-position? (lex:position-token-end-pos a-position-token))
e
(lex:position-token-end-pos a-position-token)))]
[else
;; Otherwise, we have no idea how to treat this as a token.
((current-tokenizer-error-handler) 'unknown-type (format "~a" next-token)
#f #f #f #f)])))
permissive-tokenizer)
;; positions->srcloc: position position -> (list source line column offset span)
;; Given two positions, returns a srcloc-like structure, where srcloc is the value
;; consumed as the third argument to datum->syntax.
(define (positions->srcloc start-pos end-pos)
(list (current-source)
(lex:position-line start-pos)
(lex:position-col start-pos)
(lex:position-offset start-pos)
(if (and (number? (lex:position-offset end-pos))
(number? (lex:position-offset start-pos)))
(- (lex:position-offset end-pos)
(lex:position-offset start-pos))
#f)))
#|
MB: The next three functions control the appearance of the generated parse tree.
|#
;; We create a syntax using read-syntax; by definition, it should have the
;; original? property set to #t, which we then copy over to syntaxes constructed
;; with atomic-datum->syntax and rule-components->syntax.
(define stx-with-original?-property
(read-syntax #f (open-input-string "original")))
;; atomic-datum->syntax: datum position position
;; Helper that does the ugly work in wrapping a datum into a syntax
;; with source location.
(define (atomic-datum->syntax d start-pos end-pos)
(syntax-property (datum->syntax #f d (positions->srcloc start-pos end-pos) stx-with-original?-property) 'foo 'atom))
;; rule-components->syntax: (U symbol false) (listof stx) ... #:srcloc (U #f (list src line column offset span)) -> stx
;; Creates an stx out of the rule name and its components.
;; The location information of the rule spans that of its components.
(define (rule-components->syntax rule-name/false #:srcloc [srcloc #f] . components)
(define flattened-components (apply append components))
(syntax-property (datum->syntax #f
(apply append
(list
(syntax-property (datum->syntax #f rule-name/false srcloc stx-with-original?-property) 'foo 'rule-name))
components)
srcloc
stx-with-original?-property) 'foo 'whole-rule))

0
brag/brag/codegen/satisfaction.rkt → beautiful-racket-ragg/br/ragg/codegen/satisfaction.rkt
View File

6
brag/brag/codegen/sexp-based-lang.rkt → beautiful-racket-ragg/br/ragg/codegen/sexp-based-lang.rkt
View File

@ -11,7 +11,7 @@
;; The intended use of this language is as follows:
;;
;;;;; s-exp-grammar.rkt ;;;;;;;;;
;; #lang brag
;; #lang br/ragg
;; s-exp : "(" s-exp* ")" | ATOM
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -27,7 +27,7 @@
;; defines what the uppercased tokens mean. For example, you can
;; use the parser-tools/lex lexer tools:
;;
;; (require brag/support
;; (require ragg/support
;; parser-tools/lex
;; parser-tools/lex-sre)
;;
@ -91,6 +91,6 @@
#%top-interaction)
(define-syntax (rules stx)
(rules-codegen #:parser-provider-module 'brag/cfg-parser/cfg-parser ;; 'parser-tools/yacc
(rules-codegen #:parser-provider-module 'br/ragg/cfg-parser/cfg-parser ;; 'parser-tools/yacc
#:parser-provider-form 'cfg-parser ;; 'parser
stx))

BIN
beautiful-racket-ragg/br/ragg/codegen/sexp-based-lang.rkt alias Normal file
View File

Binary file not shown.

2
brag/brag/examples/01-equal.rkt → beautiful-racket-ragg/br/ragg/examples/01-equal.rkt
View File

@ -1,4 +1,4 @@
#lang brag
#lang br/ragg
## Equal numbers of 0 and 1s in a string.
##

2
brag/brag/examples/0n1.rkt → beautiful-racket-ragg/br/ragg/examples/0n1.rkt
View File

@ -1,3 +1,3 @@
#lang brag
#lang br/ragg
rule: "0"* "1"

2
brag/brag/examples/0n1n.rkt → beautiful-racket-ragg/br/ragg/examples/0n1n.rkt
View File

@ -1,3 +1,3 @@
#lang brag
#lang br/ragg
rule-0n1n: ["0" rule-0n1n "1"]

2
brag/brag/examples/baby-json.rkt → beautiful-racket-ragg/br/ragg/examples/baby-json.rkt
View File

@ -1,4 +1,4 @@
#lang brag
#lang br/ragg
;; Simple baby example of JSON structure
json: number | string

11
brag/brag/examples/bnf.rkt → beautiful-racket-ragg/br/ragg/examples/bnf.rkt
View File

@ -1,11 +1,4 @@
#lang racket/base
#|
This grammar is permanently broken with the <elider> operator active.
|#
#|
#lang br/ragg
## The following comes from: http://en.wikipedia.org/wiki/Backus%E2%80%93Naur_Form
@ -19,5 +12,3 @@ This grammar is permanently broken with the <elider> operator active.
<list> : <term> | <term> <opt-whitespace> <list>
<term> : <literal> | "<" <RULE-NAME> ">"
<literal> : '"' <TEXT> '"' | "'" <TEXT> "'" ## actually, the original BNF did not use quotes
|#

2
brag/brag/examples/lua-parser.rkt → beautiful-racket-ragg/br/ragg/examples/lua-parser.rkt
View File

@ -1,4 +1,4 @@
#lang brag
#lang br/ragg
;; Lua parser, adapted from:
;; http://www.lua.org/manual/5.1/manual.html#8

2
brag/brag/examples/nested-word-list.rkt → beautiful-racket-ragg/br/ragg/examples/nested-word-list.rkt
View File

@ -1,3 +1,3 @@
#lang brag
#lang br/ragg
nested-word-list: WORD
| LEFT-PAREN nested-word-list* RIGHT-PAREN

2
brag/brag/examples/python-grammar.rkt → beautiful-racket-ragg/br/ragg/examples/python-grammar.rkt
View File

@ -1,4 +1,4 @@
#lang brag
#lang br/ragg
# Grammar for Python

2
brag/brag/examples/simple-arithmetic-grammar.rkt → beautiful-racket-ragg/br/ragg/examples/simple-arithmetic-grammar.rkt
View File

@ -1,4 +1,4 @@
#lang brag
#lang br/ragg
expr : term ('+' term)*
term : factor ('*' factor)*

2
brag/brag/examples/simple-line-drawing.rkt → beautiful-racket-ragg/br/ragg/examples/simple-line-drawing.rkt
View File

@ -1,4 +1,4 @@
#lang brag
#lang br/ragg
;;
;; See: http://stackoverflow.com/questions/12345647/rewrite-this-script-by-designing-an-interpreter-in-racket

4
beautiful-racket-ragg/br/ragg/examples/simple-line-drawing/examples/letter-i.rkt Executable file
View File

@ -0,0 +1,4 @@
#lang br/ragg/examples/simple-line-drawing
3 9 X;
6 3 b 3 X 3 b;
3 9 X;

2
brag/brag/examples/simple-line-drawing/grammar.rkt → beautiful-racket-ragg/br/ragg/examples/simple-line-drawing/grammar.rkt
View File

@ -1,4 +1,4 @@
#lang brag
#lang br/ragg
;;
;; See: http://stackoverflow.com/questions/12345647/rewrite-this-script-by-designing-an-interpreter-in-racket

0
brag/brag/examples/simple-line-drawing/interpret.rkt → beautiful-racket-ragg/br/ragg/examples/simple-line-drawing/interpret.rkt
View File

6
brag/brag/examples/simple-line-drawing/lang/reader.rkt → beautiful-racket-ragg/br/ragg/examples/simple-line-drawing/lang/reader.rkt
View File

@ -1,12 +1,12 @@
#lang s-exp syntax/module-reader
brag/examples/simple-line-drawing/semantics
br/ragg/examples/simple-line-drawing/semantics
#:read my-read
#:read-syntax my-read-syntax
#:info my-get-info
#:whole-body-readers? #t
(require brag/examples/simple-line-drawing/lexer
brag/examples/simple-line-drawing/grammar)
(require br/ragg/examples/simple-line-drawing/lexer
br/ragg/examples/simple-line-drawing/grammar)
(define (my-read in)
(syntax->datum (my-read-syntax #f in)))

2
brag/brag/examples/simple-line-drawing/lexer.rkt → beautiful-racket-ragg/br/ragg/examples/simple-line-drawing/lexer.rkt
View File

@ -3,7 +3,7 @@
(provide tokenize)
;; A simple lexer for simple-line-drawing.
(require brag/support
(require br/ragg/support
parser-tools/lex)
(define (tokenize ip)

0
brag/brag/examples/simple-line-drawing/semantics.rkt → beautiful-racket-ragg/br/ragg/examples/simple-line-drawing/semantics.rkt
View File

2
brag/brag/examples/statlist-grammar.rkt → beautiful-racket-ragg/br/ragg/examples/statlist-grammar.rkt
View File

@ -1,4 +1,4 @@
#lang brag
#lang br/ragg
## Statlist grammar

2
brag/brag/examples/wordy.rkt → beautiful-racket-ragg/br/ragg/examples/wordy.rkt
View File

@ -1,4 +1,4 @@
#lang brag
#lang br/ragg
;; A parser for a silly language
sentence: verb optional-adjective object
verb: greeting

11
beautiful-racket-ragg/br/ragg/info.rkt Executable file
View File

@ -0,0 +1,11 @@
#lang setup/infotab
(define name "ragg")
(define categories '(devtools))
(define can-be-loaded-with 'all)
(define required-core-version "5.3.1")
(define version "1.0")
(define repositories '("4.x"))
(define scribblings '(("br-ragg.scrbl")))
(define blurb '("ragg: a Racket AST Generator Generator. A design goal is to be easy for beginners to use. Given a grammar in EBNF, ragg produces a parser that generates Racket's native syntax objects with full source location."))
(define release-notes '((p "First release.")))
(define deps (list))

6
brag/brag/private/internal-support.rkt → beautiful-racket-ragg/br/ragg/private/internal-support.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require brag/support)
(require br/ragg/support)
(provide current-source
current-parser-error-handler
@ -15,8 +15,8 @@
(make-parameter
(lambda (tok-name tok-value offset line col span)
(raise (exn:fail:parsing
(format "Encountered parsing error near ~e (token ~e) while parsing ~e [line=~a, column=~a, offset=~a]"
tok-value tok-name
(format "Encountered parsing error near token ~e (~e) while parsing ~e [line=~a, column=~a, offset=~a]"
tok-name tok-value
(current-source)
line col offset)
(current-continuation-marks)

55
brag/brag/rules/lexer.rkt → beautiful-racket-ragg/br/ragg/rules/lexer.rkt
View File

@ -1,33 +1,29 @@
#lang racket/base
(require (for-syntax racket/base "parser.rkt"))
(require parser-tools/lex
(prefix-in : parser-tools/lex-sre)
"parser.rkt"
"rule-structs.rkt"
racket/string)
"rule-structs.rkt")
(provide lex/1 tokenize)
;; A newline can be any one of the following.
(define-lex-abbrev NL (:or "\r\n" "\r" "\n"))
;; chars used for quantifiers & parse-tree filtering
(define-for-syntax quantifiers "+:*") ; colon is reserved to separate rules and productions
(define-lex-trans reserved-chars
(λ(stx) #`(char-set #,(format "~a~a~a" quantifiers hide-char splice-char))))
(define-lex-trans hide-char-trans (λ(stx) #`(char-set #,(format "~a" hide-char))))
(define-lex-trans splice-char-trans (λ(stx) #`(char-set #,(format "~a" splice-char))))
;; Slightly modified from the read.rkt example in parser-tools, treating
;; +, :, and * as reserved, non-identifier characters.
(define-lex-abbrevs
[letter (:or (:/ "a" "z") (:/ #\A #\Z))]
[digit (:/ #\0 #\9)]
[id-char (:or letter digit (:& (char-set "+:*@!-.$%&/=?^_~<>") (char-complement (reserved-chars))))]
[hide-char (hide-char-trans)]
[splice-char (splice-char-trans)]
)
[letter (:or (:/ "a" "z") (:/ #\A #\Z))]
[digit (:/ #\0 #\9)]
[id-char (:or letter digit (char-set "-.!$%&/<=>?^_~@"))]
)
(define-lex-abbrev id
(:& (complement (:+ digit))
(:+ id-char)))
(define-lex-abbrev id (:& (complement (:+ digit)) (:+ id-char)))
(define lex/1
(lexer-src-pos
@ -47,10 +43,6 @@
(token-RPAREN lexeme)]
["]"
(token-RBRACKET lexeme)]
[hide-char
(token-HIDE lexeme)]
[splice-char
(token-SPLICE lexeme)]
["|"
(token-PIPE lexeme)]
[(:or "+" "*")
@ -59,33 +51,22 @@
;; Skip whitespace
(return-without-pos (lex/1 input-port))]
;; Skip comments up to end of line
;; but detect possble kwargs.
[(:: (:or "#" ";") ; remove # as comment char
[(:: (:or "#" ";")
(complement (:: (:* any-char) NL (:* any-char)))
(:or NL ""))
(let ([maybe-kwarg-match (regexp-match #px"^#:(.*?)\\s*(.*?)$" lexeme)])
(when maybe-kwarg-match
(let* ([parts (map string->symbol (string-split (string-trim lexeme "#:" #:right? #f)))]
[kw (car parts)][val (cadr parts)])
(case kw
[(prefix-out) (current-prefix-out val)]
[else (error 'lexer (format "got unknown keyword ~a" kw))])))
(return-without-pos (lex/1 input-port)))]
;; Skip comments up to end of line.
(return-without-pos (lex/1 input-port))]
[(eof)
(token-EOF lexeme)]
[(:: id (:* whitespace) ":")
(token-RULE_HEAD lexeme)]
[(:: hide-char id (:* whitespace) ":")
(token-RULE_HEAD_HIDDEN lexeme)]
[(:: splice-char id (:* whitespace) ":")
(token-RULE_HEAD_SPLICED lexeme)]
[id
(token-ID lexeme)]
;; We call the error handler for everything else:
[(:: any-char)
(let-values ([(rest-of-text end-pos-2)
(lex-nonwhitespace input-port)])
(lex-nonwhitespace input-port)])
((current-parser-error-handler)
#f
'error

134
brag/brag/rules/parser.rkt → beautiful-racket-ragg/br/ragg/rules/parser.rkt
View File

@ -7,28 +7,21 @@
;; A parser for grammars.
(provide hide-char
splice-char
tokens
(provide tokens
token-LPAREN
token-RPAREN
token-HIDE ; for hider
token-SPLICE ; for splicer
token-LBRACKET
token-RBRACKET
token-PIPE
token-REPEAT
token-RULE_HEAD
token-RULE_HEAD_HIDDEN
token-RULE_HEAD_SPLICED
token-ID
token-LIT
token-EOF
grammar-parser
current-source
current-parser-error-handler
current-prefix-out
[struct-out rule]
[struct-out lhs-id]
@ -45,20 +38,13 @@
RPAREN
LBRACKET
RBRACKET
HIDE
SPLICE
PIPE
REPEAT
RULE_HEAD
RULE_HEAD_HIDDEN
RULE_HEAD_SPLICED
ID
LIT
EOF))
(define hide-char #\/)
(define splice-char #\@)
;; grammar-parser: (-> token) -> (listof rule)
(define grammar-parser
(parser
@ -66,17 +52,17 @@
(src-pos)
(start rules)
(end EOF)
(grammar
[rules
[(rules*) $1]]
[rules*
[(rule rules*)
(cons $1 $2)]
[()
'()]]
;; I have a separate token type for rule identifiers to avoid the
;; shift/reduce conflict that happens with the implicit sequencing
;; of top-level rules. i.e. the parser can't currently tell, when
@ -92,40 +78,9 @@
(string-length trimmed))
(position-line $1-start-pos)
(position-col $1-start-pos))
trimmed
#f)
$2))]
[(RULE_HEAD_HIDDEN pattern) ; bang indicates hiding
(begin
(define trimmed (cadr (regexp-match (pregexp (format "~a(\\S+)\\s*:$" hide-char)) $1)))
(rule (position->pos $1-start-pos)
(position->pos $2-end-pos)
(lhs-id (position->pos $1-start-pos)
(pos (+ (position-offset $1-start-pos)
(string-length trimmed)
(string-length "!"))
(position-line $1-start-pos)
(position-col $1-start-pos))
trimmed
''hide) ; symbol needs to be double quoted in this case
$2))]
[(RULE_HEAD_SPLICED pattern) ;atsign indicates splicinh
(begin
(define trimmed (cadr (regexp-match (pregexp (format "~a(\\S+)\\s*:$" splice-char)) $1)))
(rule (position->pos $1-start-pos)
(position->pos $2-end-pos)
(lhs-id (position->pos $1-start-pos)
(pos (+ (position-offset $1-start-pos)
(string-length trimmed)
(string-length "@"))
(position-line $1-start-pos)
(position-col $1-start-pos))
trimmed
''splice) ; symbol needs to be double quoted in this case
trimmed)
$2))]]
[pattern
[(implicit-pattern-sequence PIPE pattern)
(if (pattern-choice? $3)
@ -137,7 +92,7 @@
(list $1 $3)))]
[(implicit-pattern-sequence)
$1]]
[implicit-pattern-sequence
[(repeatable-pattern implicit-pattern-sequence)
(if (pattern-seq? $2)
@ -149,7 +104,7 @@
(list $1 $2)))]
[(repeatable-pattern)
$1]]
[repeatable-pattern
[(atomic-pattern REPEAT)
(cond [(string=? $2 "*")
@ -164,70 +119,55 @@
(error 'grammar-parse "unknown repetition operator ~e" $2)])]
[(atomic-pattern)
$1]]
[atomic-pattern
[(LIT)
(pattern-lit (position->pos $1-start-pos)
(position->pos $1-end-pos)
(substring $1 1 (sub1 (string-length $1)))
#f)]
(substring $1 1 (sub1 (string-length $1))))]
[(ID)
(if (token-id? $1)
(pattern-token (position->pos $1-start-pos)
(position->pos $1-end-pos)
$1
#f)
$1)
(pattern-id (position->pos $1-start-pos)
(position->pos $1-end-pos)
$1
#f))]
$1))]
[(LBRACKET pattern RBRACKET)
(pattern-maybe (position->pos $1-start-pos)
(position->pos $3-end-pos)
$2)]
[(LPAREN pattern RPAREN)
(relocate-pattern $2 (position->pos $1-start-pos) (position->pos $3-end-pos))]
[(HIDE atomic-pattern)
(relocate-pattern $2 (position->pos $1-start-pos) (position->pos $2-end-pos) 'hide)]
(relocate-pattern $2 (position->pos $1-start-pos) (position->pos $3-end-pos))]])
[(SPLICE ID)
;; only works for nonterminals on the right side
;; (meaningless with terminals)
(if (token-id? $2)
(error 'brag "Can't use splice operator with terminal")
(pattern-id (position->pos $1-start-pos)
(position->pos $2-end-pos)
$2
'splice))]])
(error (lambda (tok-ok? tok-name tok-value start-pos end-pos)
((current-parser-error-handler) tok-ok? tok-name tok-value (position->pos start-pos) (position->pos end-pos))))))
;; relocate-pattern: pattern -> pattern
;; Rewrites the pattern's start and end pos accordingly.
(define (relocate-pattern a-pat start-pos end-pos [hide? #f])
(define (relocate-pattern a-pat start-pos end-pos)
(match a-pat
[(pattern-id _ _ v h)
(pattern-id start-pos end-pos v (or hide? h))]
[(pattern-token _ _ v h)
(pattern-token start-pos end-pos v (or hide? h))]
[(pattern-lit _ _ v h)
(pattern-lit start-pos end-pos v (or hide? h))]
[(pattern-choice _ _ vs)
(pattern-choice start-pos end-pos vs)]
[(pattern-repeat _ _ m v)
(pattern-repeat start-pos end-pos m v)]
[(pattern-maybe _ _ v)
(pattern-maybe start-pos end-pos v)]
[(pattern-seq _ _ vs)
(pattern-seq start-pos end-pos vs)]
[else
(error 'relocate-pattern "Internal error when relocating ~s\n" a-pat)]))
[(pattern-id _ _ v)
(pattern-id start-pos end-pos v)]
[(pattern-token _ _ v)
(pattern-token start-pos end-pos v)]
[(pattern-lit _ _ v)
(pattern-lit start-pos end-pos v)]
[(pattern-choice _ _ vs)
(pattern-choice start-pos end-pos vs)]
[(pattern-repeat _ _ m v)
(pattern-repeat start-pos end-pos m v)]
[(pattern-maybe _ _ v)
(pattern-maybe start-pos end-pos v)]
[(pattern-seq _ _ vs)
(pattern-seq start-pos end-pos vs)]
[else
(error 'relocate-pattern "Internal error when relocating ~s\n" a-pat)]))
; token-id: string -> boolean
@ -251,14 +191,12 @@
;; During parsing, we should define the source of the input.
(define current-source (make-parameter #f))
(define current-prefix-out (make-parameter #f))
;; When bad things happen, we need to emit errors with source location.
(struct exn:fail:parse-grammar exn:fail (srclocs)
#:transparent
#:property prop:exn:srclocs (lambda (instance)
(exn:fail:parse-grammar-srclocs instance)))
#:transparent
#:property prop:exn:srclocs (lambda (instance)
(exn:fail:parse-grammar-srclocs instance)))
(define current-parser-error-handler
(make-parameter

12
brag/brag/rules/rule-structs.rkt → beautiful-racket-ragg/br/ragg/rules/rule-structs.rkt
View File

@ -7,25 +7,29 @@
(struct pos (offset line col)
#:transparent)
(struct rule (start end lhs pattern)
#:transparent)
(struct lhs-id (start end val splice)
(struct lhs-id (start end val)
#:transparent)
;; A pattern can be one of the following:
(struct pattern (start end)
#:transparent)
(struct pattern-id pattern (val hide)
(struct pattern-id pattern (val)
#:transparent)
;; Token structure to be defined by the user
(struct pattern-token pattern (val hide)
(struct pattern-token pattern (val)
#:transparent)
;; Token structure defined as the literal string to be matched.
(struct pattern-lit pattern (val hide)
(struct pattern-lit pattern (val)
#:transparent)
(struct pattern-choice pattern (vals)

0
brag/brag/rules/runtime.rkt → beautiful-racket-ragg/br/ragg/rules/runtime.rkt
View File

0
brag/brag/rules/stx-types.rkt → beautiful-racket-ragg/br/ragg/rules/stx-types.rkt
View File

76
beautiful-racket-ragg/br/ragg/rules/stx.rkt Executable file
View File

@ -0,0 +1,76 @@
#lang racket/base
(require "rule-structs.rkt"
parser-tools/lex
racket/match
syntax/strip-context)
(provide rules->stx)
;; Given a sequence of rules, we translate these to syntax objects.
;; rules->stx: (listof rule) -> syntax
(define (rules->stx source rules #:original-stx [original-stx #f])
(define rule-stxs
(map (lambda (stx) (rule->stx source stx))
rules))
(datum->syntax #f
`(rules ,@rule-stxs)
original-stx))
(define (rule->stx source a-rule)
(define id-stx
(datum->syntax #f
(string->symbol (lhs-id-val (rule-lhs a-rule)))
(list source
(pos-line (lhs-id-start (rule-lhs a-rule)))
(pos-col (lhs-id-start (rule-lhs a-rule)))
(pos-offset (lhs-id-start (rule-lhs a-rule)))
(if (and (number? (pos-offset (lhs-id-start (rule-lhs a-rule))))
(number? (pos-offset (lhs-id-end (rule-lhs a-rule)))))
(- (pos-offset (lhs-id-end (rule-lhs a-rule)))
(pos-offset (lhs-id-start (rule-lhs a-rule))))
#f))))
(define pattern-stx (pattern->stx source (rule-pattern a-rule)))
(define line (pos-line (rule-start a-rule)))
(define column (pos-col (rule-start a-rule)))
(define position (pos-offset (rule-start a-rule)))
(define span (if (and (number? (pos-offset (rule-start a-rule)))
(number? (pos-offset (rule-end a-rule))))
(- (pos-offset (rule-end a-rule))
(pos-offset (rule-start a-rule)))
#f))
(datum->syntax #f
`(rule ,id-stx ,pattern-stx)
(list source line column position span)))
(define (pattern->stx source a-pattern)
(define recur (lambda (s) (pattern->stx source s)))
(define line (pos-line (pattern-start a-pattern)))
(define column (pos-col (pattern-start a-pattern)))
(define position (pos-offset (pattern-start a-pattern)))
(define span (if (and (number? (pos-offset (pattern-start a-pattern)))
(number? (pos-offset (pattern-end a-pattern))))
(- (pos-offset (pattern-end a-pattern))
(pos-offset (pattern-start a-pattern)))
#f))
(define source-location (list source line column position span))
(datum->syntax #f
(match a-pattern
[(struct pattern-id (start end val))
`(id ,(datum->syntax #f (string->symbol val) source-location))]
[(struct pattern-lit (start end val))
`(lit ,(datum->syntax #f val source-location))]
[(struct pattern-token (start end val))
`(token ,(datum->syntax #f (string->symbol val) source-location))]
[(struct pattern-choice (start end vals))
`(choice ,@(map recur vals))]
[(struct pattern-repeat (start end min val))
`(repeat ,min ,(recur val))]
[(struct pattern-maybe (start end val))
`(maybe ,(recur val))]
[(struct pattern-seq (start end vals))
`(seq ,@(map recur vals))])
source-location))

0
brag/brag/support.rkt → beautiful-racket-ragg/br/ragg/support.rkt
View File

4
brag/brag/test/exercise-python-grammar.rkt → beautiful-racket-ragg/br/ragg/test/exercise-python-grammar.rkt
View File

@ -1,6 +1,6 @@
#lang racket
(require brag/examples/python-grammar
brag/support
(require br/ragg/examples/python-grammar
br/ragg/support
python-tokenizer
racket/generator
parser-tools/lex

2
brag/brag/test/test-01-equal.rkt → beautiful-racket-ragg/br/ragg/test/test-01-equal.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require brag/examples/01-equal
(require br/ragg/examples/01-equal
rackunit)
(check-equal? (syntax->datum (parse ""))

4
brag/brag/test/test-0n1.rkt → beautiful-racket-ragg/br/ragg/test/test-0n1.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base
(require brag/examples/0n1
brag/support
(require br/ragg/examples/0n1
br/ragg/support
rackunit)
(define (lex ip)

4
brag/brag/test/test-0n1n.rkt → beautiful-racket-ragg/br/ragg/test/test-0n1n.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require brag/examples/0n1n
brag/support
(require br/ragg/examples/0n1n
br/ragg/support
rackunit)
(define (lex ip)

3
brag/brag/test/test-all.rkt → beautiful-racket-ragg/br/ragg/test/test-all.rkt
View File

@ -6,7 +6,6 @@
"test-01-equal.rkt"
"test-simple-arithmetic-grammar.rkt"
"test-baby-json.rkt"
"test-baby-json-hider.rkt"
"test-wordy.rkt"
"test-simple-line-drawing.rkt"
"test-flatten.rkt"
@ -16,4 +15,4 @@
"test-errors.rkt"
"test-old-token.rkt"
"test-weird-grammar.rkt"
(submod brag/codegen/satisfaction test))
(submod br/ragg/codegen/satisfaction test))

12
brag/brag/test/test-baby-json.rkt → beautiful-racket-ragg/br/ragg/test/test-baby-json.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require brag/examples/baby-json
brag/support
(require br/ragg/examples/baby-json
br/ragg/support
rackunit)
(check-equal?
@ -14,8 +14,14 @@
(kvpair "message" ":" (json (string "'hello world'")))
"}")))
(require sugar/debug)
(syntax-property (report (cadr (syntax->list (cadr (syntax->list (parse (list "{"
(token 'ID "message")
":"
(token 'STRING "'hello world'")
"}"))))))) 'foo)
(check-equal?
#;(check-equal?
(syntax->datum
(parse "[[[{}]],[],[[{}]]]"))
'(json (array #\[ (json (array #\[ (json (array #\[ (json (object #\{ #\})) #\])) #\])) #\, (json (array #\[ #\])) #\, (json (array #\[ (json (array #\[ (json (object #\{ #\})) #\])) #\])) #\])))

30
brag/brag/test/test-errors.rkt → beautiful-racket-ragg/br/ragg/test/test-errors.rkt
View File

@ -36,50 +36,50 @@
;; errors with position are sensitive to length of lang line
(define lang-line "#lang brag")
(define lang-line "#lang br/ragg")
(check-compile-error (format "~a" lang-line)
"The grammar does not appear to have any rules")
(check-compile-error (format "~a\nfoo" lang-line)
"Error while parsing grammar near: foo [line=2, column=0, position=12]")
"Error while parsing grammar near: foo [line=2, column=0, position=15]")
(check-compile-error (format "~a\nnumber : 42" lang-line)
"Error while parsing grammar near: 42 [line=2, column=9, position=21]")
"Error while parsing grammar near: 42 [line=2, column=9, position=24]")
(check-compile-error (format "~a\nnumber : 1" lang-line)
"Error while parsing grammar near: 1 [line=2, column=9, position=21]")
"Error while parsing grammar near: 1 [line=2, column=9, position=24]")
(check-compile-error "#lang brag\n x: NUMBER\nx:STRING"
(check-compile-error "#lang br/ragg\n x: NUMBER\nx:STRING"
"Rule x has a duplicate definition")
;; Check to see that missing definitions for rules also raise good syntax
;; errors:
(check-compile-error "#lang brag\nx:y"
(check-compile-error "#lang br/ragg\nx:y"
"Rule y has no definition")
(check-compile-error "#lang brag\nnumber : 1flarbl"
(check-compile-error "#lang br/ragg\nnumber : 1flarbl"
"Rule 1flarbl has no definition")
(check-compile-error "#lang brag\nprogram: EOF"
(check-compile-error "#lang br/ragg\nprogram: EOF"
"Token EOF is reserved and can not be used in a grammar")
;; Nontermination checks:
(check-compile-error "#lang brag\nx : x"
(check-compile-error "#lang br/ragg\nx : x"
"Rule x has no finite derivation")
(check-compile-error #<<EOF
#lang brag
#lang br/ragg
x : x y
y : "y"
EOF
@ -90,7 +90,7 @@ EOF
; This should be illegal too:
(check-compile-error #<<EOF
#lang brag
#lang br/ragg
a : "a" b
b : a | b
EOF
@ -100,7 +100,7 @@ EOF
(check-compile-error #<<EOF
#lang brag
#lang br/ragg
a : [b]
b : [c]
c : c
@ -109,7 +109,7 @@ EOF
(check-compile-error #<<EOF
#lang brag
#lang br/ragg
a : [b]
b : c
c : c
@ -118,7 +118,7 @@ EOF
(check-compile-error #<<EOF
#lang brag
#lang br/ragg
a : [a]
b : [b]
c : c
@ -130,7 +130,7 @@ EOF
(check-compile-error #<<EOF
#lang racket/base
(require brag/examples/simple-line-drawing)
(require br/ragg/examples/simple-line-drawing)
(define bad-parser (make-rule-parser crunchy))
EOF
"Rule crunchy is not defined in the grammar"

4
brag/brag/test/test-flatten.rkt → beautiful-racket-ragg/br/ragg/test/test-flatten.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require brag/rules/stx-types
brag/codegen/flatten
(require br/ragg/rules/stx-types
br/ragg/codegen/flatten
rackunit)

17
brag/brag/test/test-lexer.rkt → beautiful-racket-ragg/br/ragg/test/test-lexer.rkt
View File

@ -1,5 +1,5 @@
#lang racket/base
(require brag/rules/lexer
(require br/ragg/rules/lexer
rackunit
parser-tools/lex)
@ -56,18 +56,3 @@
(check-equal? (l "'he\\'llo'")
'(LIT "'he\\'llo'" 1 10))
(check-equal? (l "/")
'(HIDE "/" 1 2))
(check-equal? (l " /")
'(HIDE "/" 2 3))
(check-equal? (l "@")
'(SPLICE "@" 1 2))
(check-equal? (l " @")
'(SPLICE "@" 2 3))
(check-equal? (l "#:prefix-out val:")
(list 'EOF eof 18 18)) ; lexer skips kwarg

4
brag/brag/test/test-old-token.rkt → beautiful-racket-ragg/br/ragg/test/test-old-token.rkt
View File

@ -2,8 +2,8 @@
;; Make sure the old token type also works fine.
(require brag/examples/simple-line-drawing
brag/support
(require br/ragg/examples/simple-line-drawing
br/ragg/support
racket/list
parser-tools/lex
(prefix-in : parser-tools/lex-sre)

148
brag/brag/test/test-parser.rkt → beautiful-racket-ragg/br/ragg/test/test-parser.rkt
View File

@ -3,9 +3,9 @@
(require rackunit
parser-tools/lex
brag/rules/parser
brag/rules/lexer
brag/rules/rule-structs)
br/ragg/rules/parser
br/ragg/rules/lexer
br/ragg/rules/rule-structs)
;; quick-and-dirty helper for pos construction.
@ -17,121 +17,97 @@
;; FIXME: fix the test cases so they work on locations rather than just offsets.
(check-equal? (grammar-parser (tokenize (open-input-string "expr : 'hello'")))
(list (rule (p 1) (p 15)
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-lit (p 8) (p 15) "hello" #f))))
(lhs-id (p 1) (p 5) "expr" )
(pattern-lit (p 8) (p 15) "hello"))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON")))
(list (rule (p 1) (p 13)
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-token (p 8) (p 13) "COLON" #f))))
(lhs-id (p 1) (p 5) "expr")
(pattern-token (p 8) (p 13) "COLON"))))
(check-equal? (grammar-parser (tokenize (open-input-string "/expr : COLON")))
(list (rule (p 1) (p 14)
(lhs-id (p 1) (p 6) "expr" ''hide)
(pattern-token (p 9) (p 14) "COLON" #f))))
(check-equal? (grammar-parser (tokenize (open-input-string "@expr : COLON")))
(list (rule (p 1) (p 14)
(lhs-id (p 1) (p 6) "expr" ''splice)
(pattern-token (p 9) (p 14) "COLON" #f))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : /COLON COLON")))
(list (rule (p 1) (p 20)
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 20)
(check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON COLON")))
(list (rule (p 1) (p 19)
(lhs-id (p 1) (p 5) "expr")
(pattern-seq (p 8) (p 19)
(list
(pattern-token (p 8) (p 14) "COLON" 'hide)
(pattern-token (p 15) (p 20) "COLON" #f))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : /thing COLON")))
(list (rule (p 1) (p 20)
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 20)
(list
(pattern-id (p 8) (p 14) "thing" 'hide)
(pattern-token (p 15) (p 20) "COLON" #f))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : @thing COLON")))
(list (rule (p 1) (p 20)
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 20)
(list
(pattern-id (p 8) (p 14) "thing" 'splice)
(pattern-token (p 15) (p 20) "COLON" #f))))))
(pattern-token (p 8) (p 13) "COLON")
(pattern-token (p 14) (p 19) "COLON"))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : 'hello'*")))
(list (rule (p 1) (p 16)
(lhs-id (p 1) (p 5) "expr" #f)
(lhs-id (p 1) (p 5) "expr" )
(pattern-repeat (p 8) (p 16)
0
(pattern-lit (p 8) (p 15) "hello" #f)))))
(pattern-lit (p 8) (p 15) "hello")))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : 'hello'+")))
(list (rule (p 1) (p 16)
(lhs-id (p 1) (p 5) "expr" #f)
(lhs-id (p 1) (p 5) "expr" )
(pattern-repeat (p 8) (p 16)
1
(pattern-lit (p 8) (p 15) "hello" #f)))))
(pattern-lit (p 8) (p 15) "hello")))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : [/'hello']")))
(list (rule (p 1) (p 18)
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-maybe (p 8) (p 18)
(pattern-lit (p 9) (p 17) "hello" 'hide)))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : ['hello']")))
(list (rule (p 1) (p 17)
(lhs-id (p 1) (p 5) "expr" )
(pattern-maybe (p 8) (p 17)
(pattern-lit (p 9) (p 16) "hello")))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON | BLAH")))
(list (rule (p 1) (p 20)
(lhs-id (p 1) (p 5) "expr" #f)
(lhs-id (p 1) (p 5) "expr")
(pattern-choice (p 8) (p 20)
(list (pattern-token (p 8) (p 13) "COLON" #f)
(pattern-token (p 16) (p 20) "BLAH" #f))))))
(list (pattern-token (p 8) (p 13) "COLON")
(pattern-token (p 16) (p 20) "BLAH"))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON | BLAH | BAZ expr")))
(list (rule (p 1) (p 31)
(lhs-id (p 1) (p 5) "expr" #f)
(lhs-id (p 1) (p 5) "expr")
(pattern-choice (p 8) (p 31)
(list (pattern-token (p 8) (p 13) "COLON" #f)
(pattern-token (p 16) (p 20) "BLAH" #f)
(list (pattern-token (p 8) (p 13) "COLON")
(pattern-token (p 16) (p 20) "BLAH")
(pattern-seq (p 23) (p 31)
(list (pattern-token (p 23) (p 26) "BAZ" #f)
(pattern-id (p 27) (p 31) "expr" #f))))))))
(list (pattern-token (p 23) (p 26) "BAZ")
(pattern-id (p 27) (p 31) "expr"))))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : one two three")))
(list (rule (p 1) (p 21)
(lhs-id (p 1) (p 5) "expr")
(pattern-seq (p 8) (p 21) (list (pattern-id (p 8) (p 11) "one")
(pattern-id (p 12) (p 15) "two")
(pattern-id (p 16) (p 21) "three"))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : one two /three")))
(list (rule (p 1) (p 22)
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one" #f)
(pattern-id (p 12) (p 15) "two" #f)
(pattern-id (p 16) (p 22) "three" 'hide))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : (one two three)")))
(list (rule (p 1) (p 23)
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 23) (list (pattern-id (p 9) (p 12) "one" #f)
(pattern-id (p 13) (p 16) "two" #f)
(pattern-id (p 17) (p 22) "three" #f))))))
(lhs-id (p 1) (p 5) "expr")
(pattern-seq (p 8) (p 23) (list (pattern-id (p 9) (p 12) "one")
(pattern-id (p 13) (p 16) "two")
(pattern-id (p 17) (p 22) "three"))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : one two* three")))
(list (rule (p 1) (p 22)
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one" #f)
(pattern-repeat (p 12) (p 16) 0 (pattern-id (p 12) (p 15) "two" #f))
(pattern-id (p 17) (p 22) "three" #f))))))
(lhs-id (p 1) (p 5) "expr")
(pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one")
(pattern-repeat (p 12) (p 16) 0 (pattern-id (p 12) (p 15) "two"))
(pattern-id (p 17) (p 22) "three"))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : one two+ three")))
(list (rule (p 1) (p 22)
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one" #f)
(pattern-repeat (p 12) (p 16) 1 (pattern-id (p 12) (p 15) "two" #f))
(pattern-id (p 17) (p 22) "three" #f))))))
(lhs-id (p 1) (p 5) "expr")
(pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one")
(pattern-repeat (p 12) (p 16) 1 (pattern-id (p 12) (p 15) "two"))
(pattern-id (p 17) (p 22) "three"))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : (one two)+ three")))
(list (rule (p 1) (p 24)
(lhs-id (p 1) (p 5) "expr" #f)
(lhs-id (p 1) (p 5) "expr")
(pattern-seq (p 8) (p 24) (list (pattern-repeat (p 8) (p 18) 1
(pattern-seq (p 8) (p 17)
(list (pattern-id (p 9) (p 12) "one" #f)
(pattern-id (p 13) (p 16) "two" #f))))
(pattern-id (p 19) (p 24) "three" #f))))))
(list (pattern-id (p 9) (p 12) "one")
(pattern-id (p 13) (p 16) "two"))))
(pattern-id (p 19) (p 24) "three"))))))
(check-equal? (grammar-parser (tokenize (open-input-string #<<EOF
@ -141,13 +117,13 @@ stat: ID '=' expr
EOF
)))
(list (rule (p 1) (p 17)
(lhs-id (p 1) (p 9) "statlist" #f)
(pattern-repeat (p 12) (p 17) 1 (pattern-id (p 12) (p 16) "stat" #f)))
(lhs-id (p 1) (p 9) "statlist")
(pattern-repeat (p 12) (p 17) 1 (pattern-id (p 12) (p 16) "stat")))
(rule (p 18) (p 54)
(lhs-id (p 18) (p 22) "stat" #f)
(pattern-choice (p 24) (p 54) (list (pattern-seq (p 24) (p 35) (list (pattern-token (p 24) (p 26) "ID" #f)
(pattern-lit (p 27) (p 30) "=" #f)
(pattern-id (p 31) (p 35) "expr" #f)))
(pattern-seq (p 42) (p 54) (list (pattern-lit (p 42) (p 49) "print" #f)
(pattern-id (p 50) (p 54) "expr" #f))))))))
(lhs-id (p 18) (p 22) "stat")
(pattern-choice (p 24) (p 54) (list (pattern-seq (p 24) (p 35) (list (pattern-token (p 24) (p 26) "ID")
(pattern-lit (p 27) (p 30) "=")
(pattern-id (p 31) (p 35) "expr")))
(pattern-seq (p 42) (p 54) (list (pattern-lit (p 42) (p 49) "print")
(pattern-id (p 50) (p 54) "expr"))))))))

4
brag/brag/test/test-simple-arithmetic-grammar.rkt → beautiful-racket-ragg/br/ragg/test/test-simple-arithmetic-grammar.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require brag/examples/simple-arithmetic-grammar
brag/support
(require br/ragg/examples/simple-arithmetic-grammar
br/ragg/support
racket/set
parser-tools/lex
racket/list

4
brag/brag/test/test-simple-line-drawing.rkt → beautiful-racket-ragg/br/ragg/test/test-simple-line-drawing.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base
(require brag/examples/simple-line-drawing
brag/support
(require br/ragg/examples/simple-line-drawing
br/ragg/support
racket/list
parser-tools/lex
(prefix-in : parser-tools/lex-sre)

0
brag/brag/test/test-weird-grammar.rkt → beautiful-racket-ragg/br/ragg/test/test-weird-grammar.rkt
View File

4
brag/brag/test/test-wordy.rkt → beautiful-racket-ragg/br/ragg/test/test-wordy.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require brag/examples/wordy
brag/support
(require br/ragg/examples/wordy
br/ragg/support
rackunit)
(check-equal?

2
brag/brag/test/weird-grammar.rkt → beautiful-racket-ragg/br/ragg/test/weird-grammar.rkt
View File

@ -1,4 +1,4 @@
#lang brag
#lang br/ragg
;; This used to fail when we had the yacc-based backend, but
;; cfg-parser seems to be ok with it.

0
brag/info.rkt → beautiful-racket-ragg/info.rkt
View File

19
beautiful-racket/br/demo/basic/3dplot.bas
View File

@ -1,19 +0,0 @@
#lang br/demo/basic
1 PRINT TAB(32);"3D PLOT"
2 PRINT TAB(15);"CREATIVE COMPUTING MORRISTOWN, NEW JERSEY"
3 PRINT:PRINT:PRINT
5 DEF FNA(Z)=30*EXP(-Z*Z/100)
100 PRINT
110 FOR X=-30 TO 30 STEP 1.5
120 L=0
130 Y1=5*INT(SQR(900-X*X)/5)
140 FOR Y=Y1 TO -Y1 STEP -5
150 Z=INT(25+FNA(SQR(X*X+Y*Y))-.7*Y)
160 IF Z<=L THEN 190
170 L=Z
180 PRINT TAB(Z);"*";
190 NEXT Y
200 PRINT
210 NEXT X
300 END

140
beautiful-racket/br/demo/basic/amazing.bas
View File

@ -1,140 +0,0 @@
#lang br/demo/basic
10 PRINT TAB(28);"AMAZING PROGRAM"
20 PRINT TAB(15);"CREATIVE COMPUTING MORRISTOWN, NEW JERSEY"
30 PRINT:PRINT:PRINT:PRINT
100 INPUT "WHAT ARE YOUR WIDTH AND LENGTH";HMAX,VMAX
102 IF HMAX<>1 AND VMAX<>1 THEN 110
104 PRINT "MEANINGLESS DIMENSIONS. TRY AGAIN.":GOTO 100
110 DIM W(HMAX,VMAX),V(HMAX,VMAX)
120 PRINT
130 PRINT
140 PRINT
150 PRINT
160 Q=0:Z=0:X=INT(RND(1)*HMAX+1)
165 FOR I=1 TO HMAX
170 IF I=X THEN 173
171 PRINT "+--";:GOTO 180
173 PRINT "+ ";
180 NEXT I
190 PRINT "+"
195 C=1:W(X,1)=C:C=C+1
200 R=X:S=1:GOTO 260
210 IF R<>HMAX THEN 240
215 IF S<>VMAX THEN 230
220 R=1:S=1:GOTO 250
230 R=1:S=S+1:GOTO 250
240 R=R+1
250 IF W(R,S)=0 THEN 210
260 IF R-1=0 THEN 530
265 IF W(R-1,S)<>0 THEN 530
270 IF S-1=0 THEN 390
280 IF W(R,S-1)<>0 THEN 390
290 IF R=HMAX THEN 330
300 IF W(R+1,S)<>0 THEN 330
310 X=INT(RND(1)*3+1)
320 ON X GOTO 790,820,860
330 IF S<>HMAX THEN 340
334 IF Z=1 THEN 370
338 Q=1:GOTO 350
340 IF W(R,S+1)<>0 THEN 370
350 X=INT(RND(1)*3+1)
360 ON X GOTO 790,820,910
370 X=INT(RND(1)*2+1)
380 ON X GOTO 790,820
390 IF R=HMAX THEN 470
400 IF W(R+1,S)<>0 THEN 470
405 IF S<>VMAX THEN 420
410 IF Z=1 THEN 450
415 Q=1:GOTO 430
420 IF W(R,S+1)<>0 THEN 450
430 X=INT(RND(1)*3+1)
440 ON X GOTO 790,860,910
450 X=INT(RND(1)*2+1)
460 ON X GOTO 790,860
470 IF S<>VMAX THEN 490
480 IF Z=1 THEN 520
485 Q=1:GOTO 500
490 IF W(R,S+1)<>0 THEN 520
500 X=INT(RND(1)*2+1)
510 ON X GOTO 790,910
520 GOTO 790
530 IF S-1=0 THEN 670
540 IF W(R,S-1)<>0 THEN 670
545 IF R=HMAX THEN 610
547 IF W(R+1,S)<>0 THEN 610
550 IF S<>VMAX THEN 560
552 IF Z=1 THEN 590
554 Q=1:GOTO 570
560 IF W(R,S+1)<>0 THEN 590
570 X=INT(RND(1)*3+1)
580 ON X GOTO 820,860,910
590 X=INT(RND(1)*2+1)
600 ON X GOTO 820,860
610 IF S<>VMAX THEN 630
620 IF Z=1 THEN 660
625 Q=1:GOTO 640
630 IF W(R,S+1)<>0 THEN 660
640 X=INT(RND(1)*2+1)
650 ON X GOTO 820,910
660 GOTO 820
670 IF R=HMAX THEN 740
680 IF W(R+1,S)<>0 THEN 740
685 IF S<>VMAX THEN 700
690 IF Z=1 THEN 730
695 Q=1:GOTO 830
700 IF W(R,S+1)<>0 THEN 730
710 X=INT(RND(1)*2+1)
720 ON X GOTO 860,910
730 GOTO 860
740 IF S<>VMAX THEN 760
750 IF Z=1 THEN 780
755 Q=1:GOTO 770
760 IF W(R,S+1)<>0 THEN 780
770 GOTO 910
780 GOTO 1000
790 W(R-1,S)=C
800 C=C+1:V(R-1,S)=2:R=R-1
810 IF C=HMAX*VMAX+1 THEN 1010
815 Q=0:GOTO 260
820 W(R,S-1)=C
830 C=C+1
840 V(R,S-1)=1:S=S-1:IF C=HMAX*VMAX+1 THEN 1010
850 Q=0:GOTO 260
860 W(R+1,S)=C
870 C=C+1:IF V(R,S)=0 THEN 880
875 V(R,S)=3:GOTO 890
880 V(R,S)=2
890 R=R+1
900 IF C=HMAX*VMAX+1 THEN 1010
905 GOTO 530
910 IF Q=1 THEN 960
920 W(R,S+1)=C:C=C+1:IF V(R,S)=0 THEN 940
930 V(R,S)=3:GOTO 950
940 V(R,S)=1
950 S=S+1:IF C=HMAX*VMAX+1 THEN 1010
955 GOTO 260
960 Z=1
970 IF V(R,S)=0 THEN 980
975 V(R,S)=3:Q=0:GOTO 1000
980 V(R,S)=1:Q=0:R=1:S=1:GOTO 250
1000 GOTO 210
1010 FOR J=1 TO VMAX
1011 PRINT "|";
1012 FOR I=1 TO HMAX
1013 IF V(I,J)<2 THEN 1030
1020 PRINT " ";
1021 GOTO 1040
1030 PRINT " |";
1040 NEXT I
1041 PRINT
1043 FOR I=1 TO HMAX
1045 IF V(I,J)=0 THEN 1060
1050 IF V(I,J)=2 THEN 1060
1051 PRINT "+ ";
1052 GOTO 1070
1060 PRINT "+--";
1070 NEXT I
1071 PRINT "+"
1072 NEXT J
1073 END

55
beautiful-racket/br/demo/basic/bounce.bas
View File

@ -1,55 +0,0 @@
#lang br/demo/basic
10 PRINT TAB(33);"BOUNCE"
20 PRINT TAB(15);"CREATIVE COMPUTING MORRISTOWN, NEW JERSEY"
30 PRINT:PRINT:PRINT
90 DIM T(20)
100 PRINT "THIS SIMULATION LETS YOU SPECIFY THE INITIAL VELOCITY"
110 PRINT "OF A BALL THROWN STRAIGHT UP, AND THE COEFFICIENT OF"
120 PRINT "ELASTICITY OF THE BALL. PLEASE USE A DECIMAL FRACTION"
130 PRINT "COEFFICIENCY (LESS THAN 1)."
131 PRINT
132 PRINT "YOU ALSO SPECIFY THE TIME INCREMENT TO BE USED IN"
133 PRINT "'STROBING' THE BALL'S FLIGHT (TRY .1 INITIALLY)."
134 PRINT
135 INPUT "TIME INCREMENT (SEC)";S2
140 PRINT
150 INPUT "VELOCITY (FPS)";V
160 PRINT
170 INPUT "COEFFICIENT";C
180 PRINT
182 PRINT "FEET"
184 PRINT
186 S1=INT(70/(V/(16*S2)))
190 FOR I=1 TO S1
200 T(I)=V*C^(I-1)/16
210 NEXT I
220 FOR H=INT(-16*(V/32)^2+V^2/32+.5) TO 0 STEP -.5
221 IF INT(H)<>H THEN 225
222 PRINT H;
225 L=0
230 FOR I=1 TO S1
240 FOR TI=0 TO T(I) STEP S2
245 L=L+S2
250 IF ABS(H-(.5*(-32)*TI^2+V*C^(I-1)*TI))>.25 THEN 270
260 PRINT TAB(L/S2);"0";
270 NEXT TI
275 TI=T(I+1)/2
276 IF -16*TI^2+V*C^(I-1)*TI<H THEN 290
280 NEXT I
290 PRINT
300 NEXT H
310 PRINT TAB(1);
320 FOR I=1 TO INT(L+1)/S2+1
330 PRINT ".";
340 NEXT I
350 PRINT
355 PRINT " 0";
360 FOR I=1 TO INT(L+.9995)
380 PRINT TAB(INT(I/S2));I;
390 NEXT I
400 PRINT
410 PRINT TAB(INT(L+1)/(2*S2)-2);"SECONDS"
420 PRINT
430 GOTO 135
440 END

49
beautiful-racket/br/demo/basic/chemist.bas
View File

@ -1,30 +1,29 @@
#lang br/demo/basic
3 print TAB(33);"Chemist"
6 print TAB(15);"Creative Computing | Morristown, New Jersey"
8 print:print:print
10 print "The fictitious chemical kryptocyanic acid can only be"
20 print "diluted by the ratio of 7 parts water to 3 parts acid."
30 print "if any other ratio is attempted, the acid becomes unstable"
40 print "and soon explodes. Given the amount of acid, you must"
50 print "decide who much water to add for dilution. If you miss,"
60 print "you face the consequences."
100 A=INT(RND(50))
3 PRINT TAB(33);"CHEMIST"
6 PRINT TAB(15);"CREATIVE COMPUTING MORRISTOWN, NEW JERSEY"
8 PRINT:PRINT:PRINT
10 PRINT "THE FICTITIOUS CHECMICAL KRYPTOCYANIC ACID CAN ONLY BE"
20 PRINT "DILUTED BY THE RATIO OF 7 PARTS WATER TO 3 PARTS ACID."
30 PRINT "IF ANY OTHER RATIO IS ATTEMPTED, THE ACID BECOMES UNSTABLE"
40 PRINT "AND SOON EXPLODES. GIVEN THE AMOUNT OF ACID, YOU MUST"
50 PRINT "DECIDE WHO MUCH WATER TO ADD FOR DILUTION. IF YOU MISS"
60 PRINT "YOU FACE THE CONSEQUENCES."
100 A=INT(RND(1)*50)
110 W=7*A/3
115 if A=1 then P="liter" else P="liters"
120 print A; " "; P ; " of kryptocyanic acid. How much water?";
130 input R
120 PRINT A;"LITERS OF KRYPTOCYANIC ACID. HOW MUCH WATER";
130 INPUT R
140 D=ABS(W-R)
150 if D>W/20 then 200
160 print "Good job! You may breathe now, but don't inhale the fumes!"
170 print
180 goto 100
200 print "Sizzle! You have just been desalinated into a blob"
210 print "of quivering protoplasm!"
150 IF D>W/20 THEN 200
160 PRINT " GOOD JOB! YOU MAY BREATHE NOW, BUT DON'T INHALE THE FUMES!"
170 PRINT
180 GOTO 100
200 PRINT " SIZZLE! YOU HAVE JUST BEEN DESALINATED INTO A BLOB"
210 PRINT " OF QUIVERING PROTOPLASM!"
220 T=T+1
230 if T=3 then 260
240 print "However, you may try again with another life."
250 goto 100
260 print "Your 3 lives are used, but you will be long remembered for"
270 print "your contributions to the field of comic-book chemistry."
280 end
230 IF T=9 THEN 260
240 PRINT " HOWEVER, YOU MAY TRY AGAIN WITH ANOTHER LIFE."
250 GOTO 100
260 PRINT " YOUR 9 LIVES ARE USED, BUT YOU WILL BE LONG REMEMBERED FOR"
270 PRINT " YOUR CONTRIBUTIONS TO THE FIELD OF COMIC BOOK CHEMISTRY."
280 END

7
beautiful-racket/br/demo/basic/dim.bas
View File

@ -1,7 +0,0 @@
#lang br/demo/basic
5 A=5
10 DIM A(A)
20 PRINT A /* this should print 5 */
30 PRINT A(0)
40 PRINT A(5)

335
beautiful-racket/br/demo/basic/expander.rkt
View File

@ -1,271 +1,162 @@
#lang br
(require (for-syntax syntax/strip-context))
(provide #%top-interaction #%app #%datum
(rename-out [basic-module-begin #%module-begin])
(rename-out [basic-top #%top])
(all-defined-out))
(require br/stxparam (for-syntax br/datum))
; BASIC implementation details
; http://www.atariarchives.org/basicgames/showpage.php?page=i12
(begin-for-syntax
(require racket/list)
(define (gather-unique-ids stx)
(remove-duplicates (map syntax->datum (filter (λ(s) (syntax-property s 'id)) (syntax-flatten stx))) eq?)))
(define-language-variables [A 0][B 0][C 0][D 0][E 0][F 0][G 0][H 0][I 0][J 0][K 0][L 0][M 0][N 0][O 0][P 0][Q 0][R 0][S 0][T 0][U 0][V 0][W 0][X 0][Y 0][Z 0][A$ ""][B$ ""][C$ ""][D$ ""][E$ ""][F$ ""][G$ ""][H$ ""][I$ ""][J$ ""][K$ ""][L$ ""][M$ ""][N$ ""][O$ ""][P$ ""][Q$ ""][R$ ""][S$ ""][T$ ""][U$ ""][V$ ""][W$ ""][X$ ""][Y$ ""][Z$ ""])
(define-macro (basic-module-begin (basic-program PROGRAM-LINE ...))
(with-pattern ([(UNIQUE-ID ...)
(map (compose1 syntax-local-introduce (λ(id) (datum->syntax #f id)))
(gather-unique-ids #'(PROGRAM-LINE ...)))])
#'(#%module-begin
(define UNIQUE-ID 0) ...
(provide UNIQUE-ID ...)
(run PROGRAM-LINE ... (line #f (statement "end"))))))
(define #'(basic-module-begin _parse-tree ...)
#'(#%module-begin
(inject-language-variables (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z A$ B$ C$ D$ E$ F$ G$ H$ I$ J$ K$ L$ M$ N$ O$ P$ Q$ R$ S$ T$ U$ V$ W$ X$ Y$ Z$)
(println (quote _parse-tree ...))
_parse-tree ...)))
; #%app and #%datum have to be present to make #%top work
(define-macro (basic-top . ID)
(define #'(basic-top . id)
#'(begin
(displayln (format "got unbound identifier: ~a" 'ID))
(procedure-rename (λ xs (cons 'ID xs)) (string->symbol (format "undefined:~a" 'ID)))))
(displayln (format "got unbound identifier: ~a" 'id))
(procedure-rename (λ xs (cons 'id xs)) (string->symbol (format "undefined:~a" 'id)))))
(define #'(program _line ...) #'(run (list _line ...)))
(struct exn:line-not-found exn:fail ())
(define (raise-line-not-found-error ln)
(raise
(exn:line-not-found
(format "line number ~a not found in program" ln)
(current-continuation-marks))))
(struct end-program-signal exn:fail ())
(define (raise-end-program-signal)
(raise (end-program-signal "" (current-continuation-marks))))
(struct end-line-signal exn:fail ())
(define (raise-end-line-signal)
(raise (end-line-signal "" (current-continuation-marks))))
(define (run . line-list)
(define lines (list->vector line-list))
(define (find-index ln)
(define (run lines)
(define program-lines (list->vector (filter (λ(ln) (not (equal? ln "cr"))) lines)))
(define (line-number->index ln)
(or
(for/or ([idx (in-range (vector-length lines))])
(and (= ($line-number (vector-ref lines idx)) ln)
(for/or ([idx (in-range (vector-length program-lines))])
(and (= (car (vector-ref program-lines idx)) ln)
idx))
(raise-line-not-found-error ln)))
(void
(with-handlers ([end-program-signal? void])
(for/fold ([program-counter 0])
([i (in-naturals)])
(let* ([line-thunk ($line-thunk (vector-ref lines program-counter))]
[maybe-line-number (line-thunk)])
(if (number? maybe-line-number)
(find-index maybe-line-number)
(add1 program-counter)))))))
(raise
(exn:line-not-found
(format "line number ~a not found in program" ln)
(current-continuation-marks)))))
(for/fold ([program-counter 0])
([i (in-naturals)]
#:break (eq? program-counter 'end))
(cond
[(= program-counter (vector-length program-lines)) (basic:END)]
[else
(define line-function (cdr (vector-ref program-lines program-counter)))
(define maybe-next-line (and line-function (line-function)))
(cond
[(number? maybe-next-line) (line-number->index maybe-next-line)]
[(eq? 'end maybe-next-line) 'end]
[else (add1 program-counter)])]))
(void))
(define return-stack empty)
(define #'(cr-line _arg ...) #'(begin _arg ...))
(define (basic:gosub where)
(let/cc return-k
(set! return-stack (cons return-k return-stack))
(basic:goto where)))
(define current-line (make-parameter #f))
(struct $line (number thunk))
(define-macro (line NUMBER . STATEMENTS)
#'($line NUMBER (λ ()
(current-line NUMBER)
(with-handlers ([end-line-signal? (λ _ #f)]
[end-program-signal? raise]
[exn:fail? (λ(exn)
(displayln (format "in line ~a" NUMBER))
(raise exn))])
. STATEMENTS))))
(define current-return-stack (make-parameter empty))
(define-macro-cases statement
[(statement ID "=" EXPR) #'(basic:let ID EXPR)]
[(statement PROC-NAME . ARGS)
(with-pattern
([PROC-ID (prefix-id "basic:" #'PROC-NAME)])
#'(PROC-ID . ARGS))])
(define-cases #'line
[#'(_ _NUMBER (statement-list (statement "GOSUB" _WHERE)))
#'(cons _NUMBER
(λ _
(let ([return-stack (current-return-stack)])
(cond
[(or (empty? return-stack)
(not (= _NUMBER (car return-stack))))
(current-return-stack (cons _NUMBER (current-return-stack)))
(basic:GOTO _WHERE)]
[else (current-return-stack (cdr (current-return-stack)))]))))]
[#'(_ _NUMBER _STATEMENT-LIST) #'(cons _NUMBER (λ _ _STATEMENT-LIST))])
(define-macro-cases basic:let
[(_ (id-expr ID) EXPR)
#'(begin
#;(displayln (format "setting ~a = ~a in ~a" 'ID EXPR (current-line)))
(set! ID EXPR))]
[(_ (id-expr ID DIM-IDX ...) EXPR)
#'(array-set! ID DIM-IDX ... EXPR)])
(define-cases #'statement-list
[#'(_ _STATEMENT) #'(begin _STATEMENT)]
[#'(_ _STATEMENT ":" _STATEMENT-LIST) #'(begin _STATEMENT _STATEMENT-LIST)])
(define-macro-cases basic:if
[(_ COND-EXPR TRUE-EXPR FALSE-EXPR)
#'(if (true? COND-EXPR)
TRUE-EXPR
FALSE-EXPR)]
[(_ COND-EXPR TRUE-EXPR)
#'(if (true? COND-EXPR)
TRUE-EXPR
(raise-end-line-signal))]) ; special short-circuit rule for one-armed conditional
(define-cases #'statement
[#'(statement _ID "=" _EXPR) #'(set! _ID _EXPR)]
;[#'(statement "PRINT" ARG ...) #'(print ARG ...)]
;[#'(statement "RETURN" ARG ...) #'(return ARG ...)]
;[#'(statement "END" ARG ...) #'(end ARG ...)]
[#'(statement _proc-string _arg ...)
(inject-syntax ([#'PROC-ID (format-datum "basic:~a" #'_proc-string)])
#'(PROC-ID _arg ...))])
(define-cases #'basic:IF
[#'(_ _COND "THEN" _TRUE-RESULT "ELSE" _FALSE-RESULT)
#'(if (true? _COND)
_TRUE-RESULT
_FALSE-RESULT)]
[#'(_ _COND "THEN" _TRUE-RESULT)
#'(when (true? _COND)
_TRUE-RESULT)])
(define-cases #'value
[#'(value "(" _EXPR ")") #'_EXPR]
[#'(value _ID "(" _ARG ... ")") #'(_ID _ARG ...)]
[#'(value _ID-OR-DATUM) #'_ID-OR-DATUM])
(define true? (compose1 not zero?))
(define (cond->int cond) (if cond 1 0))
(define (basic:and . args) (cond->int (andmap true? args)))
(define (basic:or . args) (cond->int (ormap true? args)))
(define-macro-cases id-expr
[(_ ID) #'(cond
[(procedure? ID) (ID)]
[(array? ID) (array-ref ID (make-vector (array-rank ID) 0))] ; no subscript => zeroth element
[else ID])]
[(_ ID EXPR0 EXPR ...) #'(cond
[(procedure? ID) (ID EXPR0 EXPR ...)]
[(array? ID) (array-ref ID EXPR0 EXPR ...)]
[else (error 'id-expr-confused)])])
(define-cases #'expr-list
[#'(_ _EXPR) #'_EXPR]
[#'(_ _EXPR "," _EXPR-LIST) #'(_EXPR _EXPR-LIST)])
(define-macro-cases expr
[(_ COMP-EXPR) #'COMP-EXPR]
[(_ COMP-EXPR "and" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)]
[(_ COMP-EXPR "or" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)])
(define-macro-cases comp-expr
[(_ SUM) #'SUM]
[(_ SUM "=" COMP-EXPR)
#'(cond->int (equal? SUM COMP-EXPR))] ; special case because `=` is overloaded in basic
[(_ SUM OP-STR COMP-EXPR)
(with-pattern
([OP (replace-context #'here (prefix-id #'OP-STR))])
#'(cond->int (OP SUM COMP-EXPR)))])
(define-cases #'expr
[#'(_ _COMP-EXPR "AND" _SUBEXPR) #'(basic:and _COMP-EXPR _SUBEXPR)]
[#'(_ _COMP-EXPR "OR" _SUBEXPR) #'(basic:or _COMP-EXPR _SUBEXPR)]
[#'(_ _COMP-EXPR) #'_COMP-EXPR])
(define-cases #'comp-expr
[#'(_ _LEXPR "=" _REXPR) #'(comp-expr _LEXPR "equal?" _REXPR)] ; special case because = is overloaded
[#'(_ _LEXPR _op _REXPR) (inject-syntax ([#'OP (string->symbol (syntax->datum #'_op))])
#'(cond->int (OP _LEXPR _REXPR)))]
[#'(_ _ARG) #'_ARG])
(define <> (compose1 not equal?))
(define-macro-cases sum
[(_ SUM) #'SUM]
[(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)]
[(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)])
(define-cases #'sum
[#'(_ _TERM "+" _SUM) #'(+ _TERM _SUM)]
[#'(_ _TERM "-" _SUM) #'(- _TERM _SUM)]
[#'(_ _TERM) #'_TERM])
(define-macro-cases product
[(_ "-" VALUE) #'(- VALUE)]
[(_ VALUE) #'VALUE]
[(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)]
[(_ PRODUCT "/" VALUE) #'(/ PRODUCT VALUE)])
(define-macro-cases power
[(_ BASE) #'BASE]
[(_ BASE POWER) #'(expt BASE POWER)])
(define-macro-cases number
[(_ "-" NUM) #'(- NUM)]
[(_ NUM) #'NUM])
(define-macro-cases id-val
[(_ "-" ID) #'(- ID)]
[(_ ID) #'ID])
(define-cases #'product
[#'(_ _value "*" _product) #'(* _value _product)]
[#'(_ _value "/" _product) #'(/ _value _product)]
[#'(_ _value) #'_value])
(define print-list list)
(define (basic:print [args #f])
(define (println [x ""])
(define xstr (format "~a" x))
(displayln xstr)
(set! current-print-position 0))
(define (print x)
(define xstr (format "~a" x))
(display xstr)
(set! current-print-position (+ current-print-position (string-length xstr))))
(define (basic:PRINT args)
(match args
[#f (println)]
[(list print-list-items ... ";" pl)
(begin
(for-each
(λ(pli)
(print (if (number? pli)
(format "~a " pli)
pli)))
print-list-items)
(basic:print pl))]
[(list print-list-items ... ";") (for-each print print-list-items)]
[(list print-list-items ...)
(for-each println print-list-items)]))
[(list) (displayln "")]
[(list print-list-item ... ";" pl) (begin (for-each display print-list-item)
(basic:PRINT pl))]
[(list print-list-item ... ";") (for-each display print-list-item)]
[(list print-list-item ...) (for-each displayln print-list-item)]))
(define current-print-position 0)
(define (TAB num) (make-string (max 0 (INT (- num current-print-position))) #\space))
(define (INT num) (inexact->exact (truncate num)))
(define (TAB num) (make-string num #\space))
(define #'(INT _ARG ...) #'(inexact->exact (truncate (expr _ARG ...))))
(define (SIN num) (sin num))
(define (ABS num) (inexact->exact (abs num)))
(define (RND num) (* (random) num))
(define (EXP num) (exp num))
(define (SQR num) (sqrt num))
(define-macro-cases basic:input
[(_ (print-list . PL-ITEMS) ID ...)
(define-cases #'basic:INPUT
[#'(_ _PRINT-LIST ";" _ID)
#'(begin
(basic:print (append (print-list . PL-ITEMS) (list ";")))
(basic:input ID) ...)]
[(_ ID ...) #'(begin
(set! ID (let* ([str (read-line)]
[num (string->number (string-trim str))])
(or num str))) ...)])
(basic:PRINT (append _PRINT-LIST (list ";")))
(basic:INPUT _ID))]
[#'(_ _ID) #'(set! _ID (let* ([str (read-line)]
[num (string->number str)])
(if num num str)))])
(define (basic:goto where) where)
(define (basic:GOTO where) where)
(define-macro-cases basic:on
[(_ TEST-EXPR "goto" OPTION ...)
#'(basic:goto (list-ref (list OPTION ...) (sub1 TEST-EXPR)))]
[(_ TEST-EXPR "gosub" OPTION ...)
#'(basic:gosub (list-ref (list OPTION ...) (sub1 TEST-EXPR)))])
(define (basic:RETURN) (car (current-return-stack)))
(define (basic:return)
(define return-k (car return-stack))
(set! return-stack (cdr return-stack))
(return-k #f))
(define (basic:stop) (basic:end))
(define (basic:end) (raise-end-program-signal))
(require srfi/25)
(define-macro (basic:dim (id-expr ID EXPR ...) ...)
#'(begin
(set! ID (make-array (apply shape (append (list 0 (add1 EXPR)) ...)))) ...))
(define for-stack empty)
(define (push-for-stack thunk)
(set! for-stack (cons thunk for-stack)))
(define (pop-for-stack)
(set! for-stack (cdr for-stack)))
(define (in-closed-interval? x left right)
(define cmp (if (< left right) <= >=))
(cmp left x right))
(define-macro-cases basic:for
[(_ VAR START-VALUE END-VALUE)
#'(basic:for VAR START-VALUE END-VALUE 1)]
[(_ VAR START-VALUE END-VALUE STEP-VALUE)
#'(begin
(statement (id-expr VAR) "=" START-VALUE) ; initialize the loop counter
(let/cc return-k ; create a return point
(push-for-stack (cons 'VAR
(λ () ; thunk that increments counter & teleports back to beginning of loop
(define next-val (+ VAR STEP-VALUE))
(if (next-val . in-closed-interval? . START-VALUE END-VALUE)
(begin
(set! VAR next-val)
(return-k #f)) ; return value for subsequent visits to line
(pop-for-stack)))))
#f))]) ; return value for first visit to line
(define (handle-next [which #f])
(unless (pair? for-stack) (error 'next "for-stack is empty"))
(define for-thunk (cdr (if which
(assq which for-stack)
(car for-stack))))
(for-thunk))
(define-macro (basic:next VAR ...)
#'(handle-next 'VAR ...))
(define-macro (basic:def DEF-ID LAMBDA-ID EXPR)
#'(set! DEF-ID (λ (LAMBDA-ID) EXPR)))
(define (basic:END)
'end)

8
beautiful-racket/br/demo/basic/for.bas
View File

@ -1,8 +0,0 @@
#lang br/demo/basic
10 for A=1 to 3
20 print A
21 for B=5 to 8
22 print B
23 next B
30 next A
40 print "yay"

6
beautiful-racket/br/demo/basic/gosub.bas
View File

@ -1,9 +1,9 @@
#lang br/demo/basic
10 GOSUB 50
15 PRINT "2 of 3"
15 PRINT "BOOM"
17 GOSUB 30
20 END
30 PRINT "3 of 3"
30 PRINT "YAY"
40 RETURN
50 PRINT "1 of 3"
50 PRINT "50"
55 RETURN

2
beautiful-racket/br/demo/basic/importest.rkt
View File

@ -1,2 +0,0 @@
#lang racket
(require "for.bas")

11
beautiful-racket/br/demo/basic/on.bas
View File

@ -1,11 +0,0 @@
#lang br/demo/basic
10 X = 3
20 on X gosub 210, 220, 230
21 print "yay"
22 end
210 print "one"
211 return
220 print "two"
221 return
230 print "three"
231 return

54
beautiful-racket/br/demo/basic/parser.rkt
View File

@ -1,45 +1,35 @@
#lang brag
#lang br/ragg
basic-program : line*
;; recursive rules destucture easily in the expander
program : [CR]* [line [CR line]*] [CR]*
line: NUMBER statement [/":" statement]*
line: NUMBER statement-list
statement : "def" id /"(" id /")" /"=" expr
| "dim" id-expr [/"," id-expr]*
| "end" | "stop"
| "gosub" expr
| "goto" expr
| "on" expr ("gosub" | "goto") expr [/"," expr]*
| "if" expr /"then" (statement | expr) [/"else" (statement | expr)]
| "input" [print-list /";"] id [/"," id]*
| [/"let"] id-expr "=" expr
| "print" [print-list]
| "return"
| "for" id /"=" expr /"to" expr [/"step" expr]
| "next" [id]
statement-list : statement [":" statement-list]
print-list : expr [[";"] [print-list]]
statement : "END"
| "GOSUB" NUMBER
| "GOTO" expr
| "IF" expr "THEN" (statement | expr) ["ELSE" (statement | expr)]
| "INPUT" [print-list ";"] ID
| ID "=" expr ; change: make "LET" opt
| "PRINT" print-list
| "RETURN"
expr : comp-expr [("and" | "or") expr]
print-list : [expr [";" [print-list]]]
expr : comp-expr [("AND" | "OR") expr]
comp-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") comp-expr]
sum : [sum ("+" | "-")] product
sum : product [("+" | "-") sum]
product : [product ("*" | "/")] power
product : value [("*" | "/") product]
power : value [/"^" value]
expr-list : expr ["," expr-list]*
@value : id-val
| id-expr
| /"(" expr /")"
| number
value : ID ["(" expr-list ")"]
| "(" expr ")"
| STRING
| NUMBER
id-expr : id [/"(" expr [/"," expr]* /")"]
@id : ID
id-val : ["-"] id-expr
number : ["-"] NUMBER

21
beautiful-racket/br/demo/basic/sinewave.bas
View File

@ -1,19 +1,6 @@
#lang br/demo/basic
10 PRINT TAB(30);"SINE WAVE"
20 PRINT TAB(15);"CREATIVE COMPUTING MORRISTOWN, NEW JERSEY"
30 PRINT: PRINT: PRINT: PRINT: PRINT
40 REMARKABLE PROGRAM BY DAVID AHL
50 B=0
100 REM START LONG LOOP
110 FOR T=0 TO 40 STEP .25
120 A=INT(26+25*SIN(T))
130 PRINT TAB(A);
140 IF B=1 THEN 180
150 PRINT "CREATIVE"
160 B=1
170 GOTO 200
180 PRINT "COMPUTING"
190 B=0
200 NEXT T
999 END
1 A = 2
10 PRINT A < 2
12 C$ = "string thing"
15 PRINT A;: PRINT C$

5
beautiful-racket/br/demo/basic/tabs.bas
View File

@ -1,5 +0,0 @@
#lang br/demo/basic
5 print 30; "foo"
10 PRINT TAB(10);"*";
20 PRINT TAB(15);"*";

33
beautiful-racket/br/demo/basic/tokenizer.rkt
View File

@ -1,34 +1,33 @@
#lang br
(require parser-tools/lex parser-tools/lex-sre
brag/support
br/ragg/support
racket/string)
(provide tokenize)
(define-lex-abbrevs
(natural (repetition 1 +inf.0 numeric))
;; don't lex the leading "-": muddles "-X" and "Y-X"
(number (union (seq natural)
(seq (? natural) (seq "." natural))))
(number (union (seq (? "-") natural)
(seq (? "-") (? natural) (seq "." natural))))
(quoted-string (seq "\"" (repetition 0 +inf.0 (char-complement "\"")) "\"")))
(define (tokenize input-port)
(define (next-token)
(define get-token
(lexer-src-pos
(lexer
[(eof) eof]
[(seq "/*" (complement (seq any-string "*/" any-string)) "*/") (get-token input-port)]
[(union #\tab #\space #\newline
(seq number " REM" (repetition 0 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)]
[(union "PRINT" "print" "FOR" "for" "TO" "to" "STEP" "step" "IF" "if"
"GOTO" "goto" "INPUT" "input" "LET" "let" "NEXT" "next"
"RETURN" "return" "CLEAR" "clear" "LIST" "list" "RUN" "run"
"END" "end" "THEN" "then" "ELSE" "else" "GOSUB" "gosub"
"AND" "and" "OR" "or" "STOP" "stop" "LET" "let" "DEF" "def" "DIM" "dim" "ON" "on"
";" "=" "(" ")" "+" "-" "*" "/" "^"
"<=" ">=" "<>" "<" ">" "=" ":" ",") (string-downcase lexeme)]
[(union #\tab #\space
(seq number " REM" (repetition 1 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)]
[(seq #\newline (repetition 0 +inf.0 whitespace)) (token 'CR "cr")]
[(union "PRINT" "FOR" "TO" "STEP" "IF" "GOTO"
"INPUT" "LET" "NEXT" "RETURN"
"CLEAR" "LIST" "RUN" "END"
"THEN" "ELSE" "GOSUB" "AND" "OR"
";" "=" "(" ")" "+" "-" "*" "/"
"<=" ">=" "<>" "<" ">" "=" ":") lexeme]
[(union ",") (get-token input-port)]
[number (token 'NUMBER (string->number lexeme))]
[(seq upper-case (repetition 0 +inf.0 (or upper-case numeric)) (? "$")) (token 'ID (string->symbol lexeme))]
[(seq (repetition 1 +inf.0 upper-case) (? "$")) (token 'ID (string->symbol lexeme))]
[upper-case (token 'UPPERCASE (string->symbol lexeme))]
[quoted-string (token 'STRING (string-trim lexeme "\""))]))
(get-token input-port))
next-token)

2
beautiful-racket/br/demo/bf/bf-atsign.rkt
View File

@ -1,3 +1,3 @@
#lang reader "bf-reader.rkt"
Greatest language ever!
++++-+++-++-++[>++++-+++-++-++<-]>.[
++++++++[>++++++++<-]>.

39
beautiful-racket/br/demo/bf/bf-expander-imperative.rkt
View File

@ -1,39 +0,0 @@
#lang br/quicklang
(define-macro (bf-module-begin PARSE-TREE)
#'(#%module-begin
PARSE-TREE))
(provide (rename-out [bf-module-begin #%module-begin]))
(define-macro (bf-program OP-OR-LOOP-ARG ...)
#'(void OP-OR-LOOP-ARG ...))
(provide bf-program)
(define-macro (loop "[" OP-OR-LOOP-ARG ... "]")
#'(until (zero? (current-byte))
OP-OR-LOOP-ARG ...))
(provide loop)
(define-macro-cases op
[(op ">") #'(gt)]
[(op "<") #'(lt)]
[(op "+") #'(plus)]
[(op "-") #'(minus)]
[(op ".") #'(period)]
[(op ",") #'(comma)])
(provide op)
(define arr (make-vector 30000 0))
(define ptr 0)
(define (current-byte) (vector-ref arr ptr))
(define (set-current-byte! val) (vector-set! arr ptr val))
(define (gt) (set! ptr (add1 ptr)))
(define (lt) (set! ptr (sub1 ptr)))
(define (plus) (set-current-byte! (add1 (current-byte))))
(define (minus) (set-current-byte! (sub1 (current-byte))))
(define (period) (write-byte (current-byte)))
(define (comma) (set-current-byte! (read-byte)))

78
beautiful-racket/br/demo/bf/bf-expander.rkt
View File

@ -1,60 +1,36 @@
#lang br/quicklang
(define-macro (bf-module-begin PARSE-TREE)
#lang br
(define #'(bf-module-begin _PARSE-TREE ...)
#'(#%module-begin
PARSE-TREE))
(provide (rename-out [bf-module-begin #%module-begin]))
_PARSE-TREE ...))
(provide (rename-out [bf-module-begin #%module-begin])
#%top-interaction)
(define (fold-funcs apl bf-funcs)
(for/fold ([current-apl apl])
([bf-func (in-list bf-funcs)])
(apply bf-func current-apl)))
(define-macro (bf-program OP-OR-LOOP-ARG ...)
#'(begin
(define first-apl (list (make-vector 30000 0) 0))
(void (fold-funcs first-apl (list OP-OR-LOOP-ARG ...)))))
(define #'(bf-program _OP-OR-LOOP ...)
#'(begin _OP-OR-LOOP ...))
(provide bf-program)
(define-macro (loop "[" OP-OR-LOOP-ARG ... "]")
#'(lambda (arr ptr)
(for/fold ([current-apl (list arr ptr)])
([i (in-naturals)]
#:break (zero? (apply current-byte
current-apl)))
(fold-funcs current-apl (list OP-OR-LOOP-ARG ...)))))
(provide loop)
(define-macro-cases op
[(op ">") #'gt]
[(op "<") #'lt]
[(op "+") #'plus]
[(op "-") #'minus]
[(op ".") #'period]
[(op ",") #'comma])
(define-cases #'op
[#'(op ">") #'(move-pointer 1)]
[#'(op "<") #'(move-pointer -1)]
[#'(op "+") #'(set-current-byte! (add1 (get-current-byte)))]
[#'(op "-") #'(set-current-byte! (sub1 (get-current-byte)))]
[#'(op ".") #'(write-byte (get-current-byte))]
[#'(op ",") #'(set-current-byte! (read-byte))])
(provide op)
(define (current-byte arr ptr) (vector-ref arr ptr))
(define bf-vector (make-vector 30000 0))
(define bf-pointer 0)
(define (set-current-byte arr ptr val)
(vector-set! arr ptr val)
arr)
(define (move-pointer how-far)
(set! bf-pointer (+ bf-pointer how-far)))
(define (gt arr ptr) (list arr (add1 ptr)))
(define (lt arr ptr) (list arr (sub1 ptr)))
(define (plus arr ptr)
(list (set-current-byte arr ptr (add1 (current-byte arr ptr)))
ptr))
(define (minus arr ptr)
(list (set-current-byte arr ptr (sub1 (current-byte arr ptr)))
ptr))
(define (period arr ptr)
(write-byte (current-byte arr ptr))
(list arr ptr))
(define (comma arr ptr)
(list (set-current-byte arr ptr (read-byte)) ptr))
(define (get-current-byte)
(vector-ref bf-vector bf-pointer))
(define (set-current-byte! val)
(vector-set! bf-vector bf-pointer val))
(define #'(loop "[" _OP-OR-LOOP ... "]")
#'(until (zero? (get-current-byte))
_OP-OR-LOOP ...))
(provide loop)

2
beautiful-racket/br/demo/bf/bf-parser.rkt
View File

@ -1,4 +1,4 @@
#lang brag
#lang br/ragg
bf-program : (op | loop)*
op : ">" | "<" | "+" | "-" | "." | ","
loop : "[" (op | loop)* "]"

33
beautiful-racket/br/demo/bf/bf-reader.rkt
View File

@ -1,20 +1,21 @@
#lang br/quicklang
(require "bf-parser.rkt")
(define (read-syntax path port)
(define parse-tree (parse path (tokenize port)))
(define module-datum `(module bf-mod br/demo/bf/bf-expander
,parse-tree))
(datum->syntax #f module-datum))
(provide read-syntax)
(require parser-tools/lex brag/support)
(define (tokenize port)
#lang br
(require parser-tools/lex br/ragg/support)
(define (tokenize input-port)
(define (next-token)
(define our-lexer
(define get-token
(lexer
[(eof) eof]
[(char-set "><-.,+[]") lexeme]
[any-char (next-token)]))
(our-lexer port))
[(char-complement (char-set "><-.,+[]"))
(token 'OTHER #:skip? #t)]
[(eof) eof]))
(get-token input-port))
next-token)
(require "bf-parser.rkt")
(define (read-syntax source-path input-port)
(define parse-tree (parse source-path (tokenize input-port)))
(strip-context
(inject-syntax ([#'PARSE-TREE parse-tree])
#'(module bf-mod br/demo/bf/bf-expander
PARSE-TREE))))
(provide read-syntax)

2
beautiful-racket/br/demo/bf/test-tokenizer.rkt
View File

@ -1,5 +1,5 @@
#lang br
(require parser-tools/lex brag/support)
(require parser-tools/lex br/ragg/support)
(define+provide (tokenize ip)
(define get-token

117
beautiful-racket/br/demo/chip8.rkt
View File

@ -3,7 +3,7 @@
; http://devernay.free.fr/hacks/chip8/C8TECH10.HTM
; http://mattmik.com/files/chip8/mastering/chip8.html
(define (split-bytes val)
(define (explode-bytes val)
(cond
[(zero? val) (list 0)]
[else
@ -17,95 +17,60 @@
(module+ test
(require rackunit)
(check-equal? (split-bytes #x2B45) (list #x2 #xB #x4 #x5))
(check-equal? (split-bytes #xCD) (list #xC #xD))
(check-equal? (split-bytes #xA) (list #xA))
(check-equal? (split-bytes #x0) (list #x0)))
(check-equal? (explode-bytes #x2B45) (list #x2 #xB #x4 #x5))
(check-equal? (explode-bytes #xCD) (list #xC #xD))
(check-equal? (explode-bytes #xA) (list #xA))
(check-equal? (explode-bytes #x0) (list #x0)))
(define (join-bytes bytes)
(define (glue-bytes bytes)
(for/sum ([b (in-list (reverse bytes))]
[i (in-naturals)])
(* b (expt 16 i))))
(module+ test
(check-equal? #x2B45 (join-bytes (list #x2 #xB #x4 #x5)))
(check-equal? #xCD (join-bytes (list #xC #xD)))
(check-equal? #xA (join-bytes (list #xA)))
(check-equal? #x0 (join-bytes (list #x0))))
(check-equal? #x2B45 (glue-bytes (list #x2 #xB #x4 #x5)))
(check-equal? #xCD (glue-bytes (list #xC #xD)))
(check-equal? #xA (glue-bytes (list #xA)))
(check-equal? #x0 (glue-bytes (list #x0))))
(define-macro (define-memory-vector ID [FIELD LENGTH SIZE] ...)
(with-pattern
([(PREFIXED-ID ...) (prefix-id #'ID "-" #'(FIELD ...))]
[(PREFIXED-ID-REF ...) (suffix-id #'(PREFIXED-ID ...) "-ref")]
[(PREFIXED-ID-SET! ...) (suffix-id #'(PREFIXED-ID ...) "-set!")]
[(FIELD-OFFSET ...) (reverse (cdr
(for/fold ([accum-stxs (list #'0)])
([len-size-stx (in-list (syntax->list #'((LENGTH SIZE) ...)))])
(cons (with-pattern
([accum (car accum-stxs)]
[(len size) len-size-stx])
#'(+ (* len size) accum)) accum-stxs))))])
#'(begin
(define ID (make-vector (+ (* LENGTH SIZE) ...)))
(define (PREFIXED-ID-REF idx)
(unless (< idx LENGTH)
(raise-argument-error 'PREFIXED-ID-REF (format "index less than field length ~a" LENGTH) idx))
(join-bytes
(for/list ([i (in-range SIZE)])
(vector-ref ID (+ FIELD-OFFSET i idx)))))
...
(define (PREFIXED-ID-SET! idx val)
(unless (< idx LENGTH)
(raise-argument-error 'PREFIXED-ID-SET! (format "index less than field length ~a" LENGTH) idx))
(unless (< val (expt 16 SIZE))
(raise-argument-error 'PREFIXED-ID-SET! (format "value less than field size ~a" (expt 16 SIZE)) val))
(for ([i (in-range SIZE)]
[b (in-list (split-bytes val))])
(vector-set! ID (+ FIELD-OFFSET i idx) b))) ...)))
(define-syntax (define-memory-vector stx)
(syntax-case stx ()
[(_ ID [FIELD LENGTH SIZE] ...)
(with-syntax ([(ID-FIELD-REF ...) (map (λ(field) (format-id stx "~a-~a-ref" #'ID field)) (syntax->list #'(FIELD ...)))]
[(ID-FIELD-SET! ...) (map (λ(field) (format-id stx "~a-~a-set!" #'ID field)) (syntax->list #'(FIELD ...)))]
[(FIELD-OFFSET ...) (reverse (cdr
(for/fold ([offsets '(0)])
([len (in-list (syntax->list #'(LENGTH ...)))]
[size (in-list (syntax->list #'(SIZE ...)))])
(cons (+ (syntax-local-eval #`(* #,len #,size)) (car offsets)) offsets))))])
#'(begin
(define ID (make-vector (+ (* LENGTH SIZE) ...)))
(define (ID-FIELD-REF idx)
(unless (< idx LENGTH)
(raise-argument-error 'ID-FIELD-REF (format "index less than field length ~a" LENGTH) idx))
(glue-bytes
(for/list ([i (in-range SIZE)])
(vector-ref ID (+ FIELD-OFFSET i idx)))))
...
(define (ID-FIELD-SET! idx val)
(unless (< idx LENGTH)
(raise-argument-error 'ID-FIELD-SET! (format "index less than field length ~a" LENGTH) idx))
(unless (< val (expt 16 SIZE))
(raise-argument-error 'ID-FIELD-SET! (format "value less than field size ~a" (expt 16 SIZE)) val))
(for ([i (in-range SIZE)]
[b (in-list (explode-bytes val))])
(vector-set! ID (+ FIELD-OFFSET i idx) b))) ...))]))
(define-memory-vector chip8
(define-memory-vector chip
[opcode 1 2] ; two bytes
[memory 4096 1] ; one byte per
[V 16 1] ; one byte per
[I 2 1] ; index register, 0x000 to 0xFFF (1.5 bytes)
[pc 2 1] ; program counter, 0x000 to 0xFFF (1.5 bytes)
[I 3 1] ; index register, 0x000 to 0xFFF
[pc 3 1] ; program counter, 0x000 to 0xFFF
[gfx (* 64 32) 1] ; pixels
[delay_timer 1 1]
[sound_timer 1 1]
[stack 16 2] ; 2 bytes each
[sp 1 2] ; stack pointer
[sp 1 1] ; stack pointer
[key 16 1]) ; keys
;; Set up render system and register input callbacks
;(setup-graphics chip8)
;(setup-input chip8)
;; Initialize the Chip8 system and load the game into the memory
#;(define (initialize c)
;; Initialize registers and memory once
)
;(initialize chip8)
;(load-game chip8 "pong")
#;(define (emulate-cycle c)
; // Fetch Opcode
; // Decode Opcode
; // Execute Opcode
;
; // Update timers
)
;; Emulation loop
#;(let loop ()
;; Emulate one cycle
(emulate-cycle chip8)
;; If the draw flag is set, update the screen
(when (draw-flag? chip8)
(draw-graphics chip8))
;; Store key press state (Press and Release)
(set-keys chip8)
(loop))

33
beautiful-racket/br/demo/funstacker-h2.rkt
View File

@ -1,33 +0,0 @@
#lang br/quicklang
(define (read-syntax path port)
(define args (port->lines port))
(define arg-datums (filter-not void? (format-datums '~a args)))
(define module-datum `(module stacker-mod br/demo/funstacker
(nestify null ,@arg-datums)))
(datum->syntax #f module-datum))
(provide read-syntax)
(define-macro (stacker-module-begin HANDLE-ARGS-EXPR)
#'(#%module-begin
(display (first HANDLE-ARGS-EXPR))))
(provide (rename-out [stacker-module-begin #%module-begin]))
(require (for-syntax sugar/debug))
(define-macro-cases nestify
[(nestify ARG0) #'ARG0]
[(nestify ARG0 ARG1 ARG ...) #'(nestify (h3 ARG0 ARG1) ARG ...)])
(provide nestify)
(define (h3 stack arg)
(cond
[(number? arg) (cons arg stack)]
[(or (equal? * arg) (equal? + arg))
(define op-result (arg (first stack) (second stack)))
(cons op-result (drop stack 2))]))
(provide + * null)
(module+ test
(require rackunit)
#;(check-equal? (with-output-to-string (λ () (dynamic-require "funstacker-test.rkt" #f))) "36"))

Some files were not shown because too many files have changed in this diff Show More