Compare commits
No commits in common. "master" and "dev-elider" have entirely different histories.
master
...
dev-elider
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
15
beautiful-racket-lib/br/conditional.rkt
Normal 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))))
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -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
97
beautiful-racket-lib/br/eopl.rkt
Normal 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)))))))
|
||||
|
|
@ -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)))))))
|
||||
|
|
@ -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))]))
|
||||
|
||||
|
|
@ -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)]))
|
||||
|
|
@ -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
|
||||
br/define br/syntax br/datum br/debug br/conditional
|
||||
(for-syntax racket/base racket/syntax br/syntax br/debug br/define))
|
||||
(provide (all-from-out racket/base)
|
||||
(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)
|
||||
br/syntax br/datum br/debug br/conditional)
|
||||
(for-syntax (all-from-out racket/base racket/syntax br/syntax br/debug))
|
||||
(for-syntax caller-stx with-shared-id)) ; from br/define
|
||||
|
||||
(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)
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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)))))]))
|
||||
|
|
@ -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
|
||||
|
|
@ -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))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -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
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#lang racket
|
||||
(require "for.bas")
|
||||
|
|
@ -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
|
||||
|
|
@ -1,45 +1,35 @@
|
|||
#lang brag
|
||||
|
||||
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
|
||||
|
|
@ -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$
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang br/demo/basic
|
||||
|
||||
5 print 30; "foo"
|
||||
10 PRINT TAB(10);"*";
|
||||
20 PRINT TAB(15);"*";
|
||||
|
|
@ -6,29 +6,28 @@
|
|||
|
||||
(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)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
#lang reader "bf-reader.rkt"
|
||||
Greatest language ever!
|
||||
++++-+++-++-++[>++++-+++-++-++<-]>.[
|
||||
++++++++[>++++++++<-]>.
|
||||
|
|
@ -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)))
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
#lang br
|
||||
(require parser-tools/lex brag/support)
|
||||
(define (tokenize port)
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -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"))
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
#lang reader br/demo/funstacker
|
||||
4
|
||||
8
|
||||
|
||||
+
|
||||
3
|
||||
|
||||
*
|
||||
|
|
@ -1,31 +0,0 @@
|
|||
#lang br/quicklang
|
||||
|
||||
(define (read-syntax path port)
|
||||
(define args (port->lines port))
|
||||
(define arg-datums (format-datums '~a args))
|
||||
(define module-datum `(module stacker-mod br/demo/funstacker
|
||||
(handle-args ,@arg-datums)))
|
||||
(datum->syntax #f module-datum))
|
||||
(provide read-syntax)
|
||||
|
||||
(define-macro (funstacker-module-begin HANDLE-ARGS-EXPR)
|
||||
#'(#%module-begin
|
||||
(display (first HANDLE-ARGS-EXPR))))
|
||||
(provide (rename-out [funstacker-module-begin #%module-begin]))
|
||||
|
||||
(define (handle-args . args)
|
||||
(for/fold ([stack-acc empty])
|
||||
([arg (filter-not void? args)])
|
||||
(cond
|
||||
[(number? arg) (cons arg stack-acc)]
|
||||
[(or (equal? * arg) (equal? + arg))
|
||||
(define op-result
|
||||
(arg (first stack-acc) (second stack-acc)))
|
||||
(cons op-result (drop stack-acc 2))])))
|
||||
(provide handle-args)
|
||||
|
||||
(provide + *)
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-equal? (with-output-to-string (λ () (dynamic-require "funstacker-test.rkt" #f))) "36"))
|
||||
|
|
@ -1,100 +1,84 @@
|
|||
#lang br/quicklang
|
||||
(require (for-syntax br/syntax racket/string) rackunit racket/file)
|
||||
(provide #%module-begin (all-defined-out))
|
||||
#lang br
|
||||
(provide #%top-interaction #%module-begin #%datum (rename-out [my-top #%top]) #%app
|
||||
(all-defined-out))
|
||||
|
||||
; #%app and #%datum have to be present to make #%top work
|
||||
(define #'(my-top . id)
|
||||
#'(begin
|
||||
(displayln (format "got unbound identifier: ~a" 'id))
|
||||
(procedure-rename (λ xs (cons 'id xs)) (string->symbol (format "undefined:~a" 'id)))))
|
||||
|
||||
(define (print-cell val fmt)
|
||||
(match-define (list _ radix-letter number-strings) (regexp-match #px"^%(.)(.*)$" fmt)) ; like %B1.16.1
|
||||
(match-define (list left-margin width right-margin) (map string->number (string-split number-strings ".")))
|
||||
(cond
|
||||
[(number? val)
|
||||
(define radix (case radix-letter
|
||||
[("B") 2]))
|
||||
(string-append (make-string left-margin #\space)
|
||||
(~r val #:min-width width #:pad-string "0" #:base radix)
|
||||
(make-string right-margin #\space))]
|
||||
[(string? val) (~a val #:min-width (+ left-margin width right-margin) #:pad-string " " #:align 'center)]
|
||||
[else (error 'unknown-value)]))
|
||||
(define-inverting #'(tst-program _arg ...)
|
||||
#'(begin
|
||||
_arg ...))
|
||||
|
||||
(define-for-syntax output-here #'output-here)
|
||||
|
||||
(define (print-line output-filename cells)
|
||||
(with-output-to-file output-filename
|
||||
(λ () (printf (format "~a\n" (string-join cells "|" #:before-first "|" #:after-last "|"))))
|
||||
#:mode 'text
|
||||
#:exists 'append))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define a 123)
|
||||
(check-equal? (print-cell a "%B1.16.1") " 0000000001111011 ")
|
||||
(check-equal? (print-cell "out" "%B1.16.1") " out ")
|
||||
(check-equal? (print-cell "out" "%B3.1.3") " out ")
|
||||
(check-equal? (print-cell "in" "%B3.1.3") " in "))
|
||||
|
||||
|
||||
(define-for-syntax chip-prefix #f)
|
||||
|
||||
|
||||
(define-macro (tst-program EXPR ...)
|
||||
(with-shared-id
|
||||
(compare-files)
|
||||
#'(begin
|
||||
EXPR ...
|
||||
(compare-files))))
|
||||
|
||||
|
||||
(define-macro (load-expr CHIPFILE-STRING)
|
||||
(set! chip-prefix (string-replace (syntax->datum #'CHIPFILE-STRING) ".hdl" ""))
|
||||
(with-pattern
|
||||
([CHIPFILE.RKT (format-string "~a.rkt" #'CHIPFILE-STRING)])
|
||||
#'(require CHIPFILE.RKT)))
|
||||
|
||||
|
||||
(define-macro (output-file-expr OUTPUT-FILE-STRING)
|
||||
(with-shared-id
|
||||
(output-file output-filename)
|
||||
#'(begin
|
||||
(define output-filename OUTPUT-FILE-STRING)
|
||||
(with-output-to-file output-filename
|
||||
(λ () (printf ""))
|
||||
#:mode 'text
|
||||
#:exists 'replace))))
|
||||
|
||||
|
||||
(define-macro (compare-to-expr COMPARE-FILE-STRING)
|
||||
(with-shared-id
|
||||
(compare-files output-filename)
|
||||
#'(define (compare-files)
|
||||
(check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING)))))
|
||||
|
||||
|
||||
(define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...)
|
||||
(with-shared-id
|
||||
(eval-result eval-chip output output-filename)
|
||||
(with-pattern
|
||||
([(COL-ID ...) (suffix-id #'(COL-NAME ...))]
|
||||
[(CHIP-COL-ID ...) (prefix-id chip-prefix "-" #'(COL-NAME ...))])
|
||||
(define-inverting #'(header-expr (_filename-string _procname) (_colid ... _outid) ";")
|
||||
(inject-syntax ([#'shared-procname (shared-syntax #'_procname)]
|
||||
[#'output (shared-syntax 'output)])
|
||||
#'(begin
|
||||
(define (output COL-ID ...)
|
||||
(print-line output-filename (map print-cell (list COL-ID ...) (list FORMAT-SPEC ...))))
|
||||
(define eval-result #f)
|
||||
(define (eval-chip) (list (CHIP-COL-ID) ...))
|
||||
(output COL-NAME ...)))))
|
||||
(provide (all-defined-out))
|
||||
(define shared-procname (dynamic-require (findf file-exists? (list _filename-string (format "~a.rkt" _filename-string))) 'shared-procname))
|
||||
(display-header '_colid ... '_outid)
|
||||
(define _colid (make-parameter 0)) ...
|
||||
(define (_outid)
|
||||
(keyword-apply shared-procname
|
||||
(map (compose1 string->keyword symbol->string) (list '_colid ...))
|
||||
(list (_colid) ...) null))
|
||||
|
||||
(define (output)
|
||||
(display-values (_colid) ... (_outid))))))
|
||||
|
||||
(define-inverting #'(load-expr "load" (_filename-string _procname) ",")
|
||||
#'(_filename-string _procname))
|
||||
|
||||
(define #'(filename _filename)
|
||||
(inject-syntax ([#'filename-string (symbol->string (syntax->datum #'_filename))]
|
||||
[#'proc-name (string->symbol (cadr (regexp-match #rx"^(.*)\\.hdl$"(symbol->string (syntax->datum #'_filename)))))])
|
||||
#'(filename-string proc-name)))
|
||||
|
||||
(define-inverting #'(table-expr "output-list" _column-id ...)
|
||||
#'(_column-id ...))
|
||||
|
||||
(define-cases #'column-id
|
||||
[#'(_ _colid) #'_colid]
|
||||
[#'(_ _colid ",") #'_colid])
|
||||
|
||||
|
||||
(define-macro (set-expr IN-BUS IN-VAL)
|
||||
(with-pattern
|
||||
([CHIP-IN-BUS-ID-WRITE (prefix-id chip-prefix "-" (suffix-id #'IN-BUS "-write"))])
|
||||
#'(CHIP-IN-BUS-ID-WRITE IN-VAL)))
|
||||
(define #'(display-header _sym ...)
|
||||
#'(begin
|
||||
(apply display-values (list _sym ...))
|
||||
(apply display-dashes (list _sym ...))))
|
||||
|
||||
(define (vals->text vals)
|
||||
(string-join (map ~a vals) " | "))
|
||||
|
||||
(define (display-values . vals)
|
||||
(displayln (vals->text vals)))
|
||||
|
||||
(define (display-dashes . vals)
|
||||
(displayln (make-string (string-length (vals->text vals)) #\-)))
|
||||
|
||||
|
||||
(define-macro (eval-expr)
|
||||
(with-shared-id
|
||||
(eval-result eval-chip)
|
||||
#'(set! eval-result (eval-chip))))
|
||||
(define-inverting #'(test-expr _step-expr ... ";")
|
||||
#'(begin
|
||||
_step-expr ...))
|
||||
|
||||
|
||||
(define-macro (output-expr)
|
||||
(with-shared-id
|
||||
(output eval-result)
|
||||
#'(apply output eval-result)))
|
||||
(define-cases #'step-expr
|
||||
[#'(_ _step) #'_step]
|
||||
[#'(_ _step ",") #'_step])
|
||||
|
||||
|
||||
(define #'(set-expr "set" _id _val)
|
||||
#'(_id _val))
|
||||
|
||||
|
||||
(define #'(eval-expr "eval")
|
||||
#'(void))
|
||||
|
||||
|
||||
(define #'(output-expr "output")
|
||||
(inject-syntax ([#'output (shared-syntax 'output)])
|
||||
#'(output)))
|
||||
|
|
|
|||
19
beautiful-racket/br/demo/hdl-tst/hdlprint.rkt
Normal file
19
beautiful-racket/br/demo/hdl-tst/hdlprint.rkt
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
#lang racket
|
||||
|
||||
|
||||
(define (hdlprint val fmt)
|
||||
(match-define (list _ radix-letter number-strings) (regexp-match #px"^%(.)(.*)$" fmt)) ; like %B1.16.1
|
||||
(match-define (list left-margin width right-margin) (map string->number (string-split number-strings ".")))
|
||||
(define radix (case radix-letter
|
||||
[("B") 2]))
|
||||
(string-append (make-string left-margin #\space)
|
||||
(if (number? val)
|
||||
(~r val #:min-width width #:pad-string "0" #:base radix)
|
||||
(~a val #:min-width width #:pad-string " " #:align 'center))
|
||||
(make-string right-margin #\space)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define a 123)
|
||||
(check-equal? (hdlprint a "%B1.16.1") " 0000000001111011 ")
|
||||
(check-equal? (hdlprint "out" "%B1.16.1") " out "))
|
||||
|
|
@ -1,23 +1,23 @@
|
|||
#lang brag
|
||||
|
||||
tst-program : load-expr output-file-expr compare-to-expr output-list-expr /";" test-expr*
|
||||
tst-program : header-expr test-expr*
|
||||
|
||||
load-expr : /"load" ID /","
|
||||
header-expr : load-expr table-expr ";"
|
||||
|
||||
output-file-expr : /"output-file" ID /","
|
||||
load-expr : "load" filename ","
|
||||
|
||||
compare-to-expr : /"compare-to" ID /","
|
||||
filename : ID
|
||||
|
||||
output-list-expr : /"output-list" column [column]+
|
||||
table-expr : "output-list" column-id+
|
||||
|
||||
/column : ID FORMAT-STRING
|
||||
column-id : ID [","]
|
||||
|
||||
@test-expr : step-expr+ /";"
|
||||
test-expr : step-expr+ ";"
|
||||
|
||||
@step-expr : (set-expr | eval-expr | output-expr) [/","]
|
||||
step-expr : (set-expr | eval-expr | output-expr) [","]
|
||||
|
||||
set-expr : /"set" ID VAL
|
||||
set-expr : "set" ID VAL
|
||||
|
||||
eval-expr : /"eval"
|
||||
eval-expr : "eval"
|
||||
|
||||
output-expr : /"output"
|
||||
output-expr : "output"
|
||||
|
|
@ -7,16 +7,15 @@
|
|||
(define (tokenize input-port)
|
||||
(define (next-token)
|
||||
(define get-token
|
||||
(lexer-src-pos
|
||||
(lexer
|
||||
[(eof) eof]
|
||||
[(union
|
||||
(seq "/*" (complement (seq any-string "*/" any-string)) "*/")
|
||||
(seq "//" (repetition 1 +inf.0 (char-complement #\newline)) #\newline))
|
||||
(token 'COMMENT lexeme #:skip? #t)]
|
||||
[(union #\tab #\space #\newline) (get-token input-port)]
|
||||
[(union "load" "output-list" "output-file" "compare-to" "set" "eval" "output" (char-set ",;")) lexeme]
|
||||
[(seq "%" (repetition 1 +inf.0 (union alphabetic numeric (char-set ".")))) (token 'FORMAT-STRING lexeme)]
|
||||
[(union "load" "output-list" "set" "eval" "output" (char-set ",;")) lexeme]
|
||||
[(repetition 1 +inf.0 numeric) (token 'VAL (string->number lexeme))]
|
||||
[(repetition 1 +inf.0 (union alphabetic numeric (char-set "-."))) (token 'ID lexeme)]))
|
||||
[(repetition 1 +inf.0 (union alphabetic numeric (char-set "-."))) (token 'ID (string->symbol lexeme))]))
|
||||
(get-token input-port))
|
||||
next-token)
|
||||
|
|
|
|||
|
|
@ -1,5 +0,0 @@
|
|||
| a | b | out |
|
||||
| 0 | 0 | 0 |
|
||||
| 0 | 1 | 0 |
|
||||
| 1 | 0 | 0 |
|
||||
| 1 | 1 | 1 |
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
| a | b | out |
|
||||
| 0 | 0 | 0 |
|
||||
| 0 | 1 | 0 |
|
||||
| 1 | 0 | 0 |
|
||||
| 1 | 1 | 1 |
|
||||
14
beautiful-racket/br/demo/hdl/And.tst
Normal file
14
beautiful-racket/br/demo/hdl/And.tst
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
#lang br/demo/hdl-tst
|
||||
|
||||
/* and */
|
||||
|
||||
load And.hdl,
|
||||
output-list a, b, out;
|
||||
set a 0, set b 0,
|
||||
eval, output;
|
||||
set a 0, set b 1,
|
||||
eval, output;
|
||||
set a 1, set b 0,
|
||||
eval, output;
|
||||
set a 1, set b 1,
|
||||
eval, output;
|
||||
|
|
@ -1,31 +0,0 @@
|
|||
#lang br/demo/hdl-tst
|
||||
|
||||
// This file is part of www.nand2tetris.org
|
||||
// and the book "The Elements of Computing Systems"
|
||||
// by Nisan and Schocken, MIT Press.
|
||||
// File name: projects/01/And.tst
|
||||
|
||||
load And.hdl,
|
||||
output-file And.out,
|
||||
compare-to And.cmp,
|
||||
output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
|
||||
|
||||
set a 0,
|
||||
set b 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 0,
|
||||
set b 1,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 1,
|
||||
set b 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 1,
|
||||
set b 1,
|
||||
eval,
|
||||
output;
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
| in | sel | a | b |
|
||||
| 0 | 0 | 0 | 0 |
|
||||
| 0 | 1 | 0 | 0 |
|
||||
| 1 | 0 | 1 | 0 |
|
||||
| 1 | 1 | 0 | 1 |
|
||||
|
|
@ -16,7 +16,5 @@ CHIP DMux {
|
|||
OUT a, b;
|
||||
|
||||
PARTS:
|
||||
Not(in=sel, out=not-sel);
|
||||
And(a=in, b=not-sel, out=a);
|
||||
And(a=in, b=sel, out=b);
|
||||
Not
|
||||
}
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
| in | sel | a | b |
|
||||
| 0 | 0 | 0 | 0 |
|
||||
| 0 | 1 | 0 | 0 |
|
||||
| 1 | 0 | 1 | 0 |
|
||||
| 1 | 1 | 0 | 1 |
|
||||
|
|
@ -1,27 +0,0 @@
|
|||
// This file is part of www.nand2tetris.org
|
||||
// and the book "The Elements of Computing Systems"
|
||||
// by Nisan and Schocken, MIT Press.
|
||||
// File name: projects/01/DMux.tst
|
||||
|
||||
load DMux.hdl,
|
||||
output-file DMux.out,
|
||||
compare-to DMux.cmp,
|
||||
output-list in%B3.1.3 sel%B3.1.3 a%B3.1.3 b%B3.1.3;
|
||||
|
||||
set in 0,
|
||||
set sel 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel 1,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set in 1,
|
||||
set sel 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel 1,
|
||||
eval,
|
||||
output;
|
||||
|
|
@ -1,28 +0,0 @@
|
|||
#lang racket
|
||||
(require "DMux4Way.hdl.rkt")
|
||||
(require rackunit)
|
||||
|
||||
(DMux4Way-in (random 2))
|
||||
(DMux4Way-sel #b00)
|
||||
(check-equal? (DMux4Way-a) (DMux4Way-in))
|
||||
(check-equal? (DMux4Way-b) 0)
|
||||
(check-equal? (DMux4Way-c) 0)
|
||||
(check-equal? (DMux4Way-d) 0)
|
||||
|
||||
(DMux4Way-sel #b01)
|
||||
(check-equal? (DMux4Way-a) 0)
|
||||
(check-equal? (DMux4Way-b) (DMux4Way-in))
|
||||
(check-equal? (DMux4Way-c) 0)
|
||||
(check-equal? (DMux4Way-d) 0)
|
||||
|
||||
(DMux4Way-sel #b10)
|
||||
(check-equal? (DMux4Way-a) 0)
|
||||
(check-equal? (DMux4Way-b) 0)
|
||||
(check-equal? (DMux4Way-c) (DMux4Way-in))
|
||||
(check-equal? (DMux4Way-d) 0)
|
||||
|
||||
(DMux4Way-sel #b11)
|
||||
(check-equal? (DMux4Way-a) 0)
|
||||
(check-equal? (DMux4Way-b) 0)
|
||||
(check-equal? (DMux4Way-c) 0)
|
||||
(check-equal? (DMux4Way-d) (DMux4Way-in))
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
| in | sel | a | b | c | d |
|
||||
| 0 | 00 | 0 | 0 | 0 | 0 |
|
||||
| 0 | 01 | 0 | 0 | 0 | 0 |
|
||||
| 0 | 10 | 0 | 0 | 0 | 0 |
|
||||
| 0 | 11 | 0 | 0 | 0 | 0 |
|
||||
| 1 | 00 | 1 | 0 | 0 | 0 |
|
||||
| 1 | 01 | 0 | 1 | 0 | 0 |
|
||||
| 1 | 10 | 0 | 0 | 1 | 0 |
|
||||
| 1 | 11 | 0 | 0 | 0 | 1 |
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
// This file is part of www.nand2tetris.org
|
||||
// and the book "The Elements of Computing Systems"
|
||||
// by Nisan and Schocken, MIT Press.
|
||||
// File name: projects/01/DMux4Way.tst
|
||||
|
||||
load DMux4Way.hdl,
|
||||
output-file DMux4Way.out,
|
||||
compare-to DMux4Way.cmp,
|
||||
output-list in%B2.1.2 sel%B2.2.2 a%B2.1.2 b%B2.1.2 c%B2.1.2 d%B2.1.2;
|
||||
|
||||
set in 0,
|
||||
set sel %B00,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel %B01,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel %B10,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel %B11,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set in 1,
|
||||
set sel %B00,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel %B01,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel %B10,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel %B11,
|
||||
eval,
|
||||
output;
|
||||
|
|
@ -1,45 +0,0 @@
|
|||
#lang br/demo/hdl-tst
|
||||
|
||||
// This file is part of www.nand2tetris.org
|
||||
// and the book "The Elements of Computing Systems"
|
||||
// by Nisan and Schocken, MIT Press.
|
||||
// File name: projects/01/DMux4Way.tst
|
||||
|
||||
load DMux4Way.hdl,
|
||||
output-file DMux4Way.out,
|
||||
compare-to DMux4Way.cmp,
|
||||
output-list in%B2.1.2 sel%B2.2.2 a%B2.1.2 b%B2.1.2 c%B2.1.2 d%B2.1.2;
|
||||
|
||||
set in 0,
|
||||
set sel %B00,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel %B01,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel %B10,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel %B11,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set in 1,
|
||||
set sel %B00,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel %B01,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel %B10,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel %B11,
|
||||
eval,
|
||||
output;
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
#lang racket
|
||||
(require "DMux.hdl.rkt")
|
||||
(require rackunit)
|
||||
|
||||
(DMux-in-write 0)
|
||||
(DMux-sel-write 0)
|
||||
(check-equal? (DMux-a) 0)
|
||||
(check-equal? (DMux-b) 0)
|
||||
|
||||
(DMux-in-write 0)
|
||||
(DMux-sel-write 1)
|
||||
(check-equal? (DMux-a) 0)
|
||||
(check-equal? (DMux-b) 0)
|
||||
|
||||
(DMux-in-write 1)
|
||||
(DMux-sel-write 0)
|
||||
(check-equal? (DMux-a) 1)
|
||||
(check-equal? (DMux-b) 0)
|
||||
|
||||
(DMux-in-write 1)
|
||||
(DMux-sel-write 1)
|
||||
(check-equal? (DMux-a) 0)
|
||||
(check-equal? (DMux-b) 1)
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
#lang br/demo/hdl-tst
|
||||
#lang br/demo/hdl/tst
|
||||
|
||||
// This file is part of www.nand2tetris.org
|
||||
// and the book "The Elements of Computing Systems"
|
||||
|
|
@ -6,9 +6,10 @@
|
|||
// File name: projects/01/DMux.tst
|
||||
|
||||
load DMux.hdl,
|
||||
output-file DMux.out,
|
||||
compare-to DMux.cmp,
|
||||
output-list in%B3.1.3 sel%B3.1.3 a%B3.1.3 b%B3.1.3;
|
||||
// output-file DMux.out,
|
||||
// compare-to DMux.cmp,
|
||||
// output-list in%B3.1.3 sel%B3.1.3 a%B3.1.3 b%B3.1.3;
|
||||
output-list in, sel, a, b;
|
||||
|
||||
set in 0,
|
||||
set sel 0,
|
||||
|
|
|
|||
|
|
@ -1,32 +0,0 @@
|
|||
#lang br/demo/hdl
|
||||
|
||||
// This file is part of www.nand2tetris.org
|
||||
// and the book "The Elements of Computing Systems"
|
||||
// by Nisan and Schocken, MIT Press.
|
||||
// File name: projects/01/DMux4Way.hdl
|
||||
|
||||
/**
|
||||
* 4-way demultiplexor:
|
||||
* {a, b, c, d} = {in, 0, 0, 0} if sel == 00
|
||||
* {0, in, 0, 0} if sel == 01
|
||||
* {0, 0, in, 0} if sel == 10
|
||||
* {0, 0, 0, in} if sel == 11
|
||||
*/
|
||||
|
||||
CHIP DMux4Way {
|
||||
// todo: how should sel subscripting work?
|
||||
IN in, sel[2];
|
||||
OUT a, b, c, d;
|
||||
|
||||
PARTS:
|
||||
DMux(in=in, sel=sel[0], a=a, b=b);
|
||||
DMux(in=in, sel=sel[1], a=c, b=d);
|
||||
/*
|
||||
// the right answer: note that subscripting on right always means "read this bit";
|
||||
// subscripting on left means "write this bit"
|
||||
// build out assignment operator
|
||||
DMux(in=in, sel=sel[0], a=s0a, b=s0b);
|
||||
DMux(in=s0b, sel=sel[1], a=b, b=d);
|
||||
DMux(in=s0a, sel=sel[1], a=a, b=c);
|
||||
*/
|
||||
}
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
#lang br/demo/hdl
|
||||
|
||||
CHIP Fanout {
|
||||
IN in;
|
||||
OUT outa, outb;
|
||||
|
||||
PARTS:
|
||||
And(a=in, b=in, out=outa);
|
||||
And(a=in, b=in, out=outb);
|
||||
|
||||
}
|
||||
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
| a | b | sum | carry |
|
||||
| 0 | 0 | 0 | 0 |
|
||||
| 0 | 1 | 1 | 0 |
|
||||
| 1 | 0 | 1 | 0 |
|
||||
| 1 | 1 | 0 | 1 |
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
#lang br/demo/hdl
|
||||
|
||||
CHIP HalfAdder {
|
||||
IN a, b; // 1-bit inputs
|
||||
OUT sum, // Right bit of a + b
|
||||
carry; // Left bit of a + b
|
||||
|
||||
PARTS:
|
||||
Xor(a=a, b=b, out=sum);
|
||||
And(a=a, b=b, out=carry);
|
||||
}
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
| a | b | sum | carry |
|
||||
| 0 | 0 | 0 | 0 |
|
||||
| 0 | 1 | 1 | 0 |
|
||||
| 1 | 0 | 1 | 0 |
|
||||
| 1 | 1 | 0 | 1 |
|
||||
|
|
@ -1,31 +0,0 @@
|
|||
#lang br/demo/hdl-tst
|
||||
|
||||
// This file is part of www.nand2tetris.org
|
||||
// and the book "The Elements of Computing Systems"
|
||||
// by Nisan and Schocken, MIT Press.
|
||||
// File name: projects/02/HalfAdder.tst
|
||||
|
||||
load HalfAdder.hdl,
|
||||
output-file HalfAdder.out,
|
||||
compare-to HalfAdder.cmp,
|
||||
output-list a%B3.1.3 b%B3.1.3 sum%B3.1.3 carry%B3.1.3;
|
||||
|
||||
set a 0,
|
||||
set b 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 0,
|
||||
set b 1,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 1,
|
||||
set b 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 1,
|
||||
set b 1,
|
||||
eval,
|
||||
output;
|
||||
|
|
@ -1,39 +0,0 @@
|
|||
#lang racket
|
||||
(require "Mux.hdl.rkt")
|
||||
(require rackunit)
|
||||
|
||||
(Mux-sel-write 0)
|
||||
|
||||
(Mux-a-write 0)
|
||||
(Mux-b-write 0)
|
||||
(check-equal? (Mux-out) (Mux-a))
|
||||
|
||||
(Mux-a-write 0)
|
||||
(Mux-b-write 1)
|
||||
(check-equal? (Mux-out) (Mux-a))
|
||||
|
||||
(Mux-a-write 1)
|
||||
(Mux-b-write 0)
|
||||
(check-equal? (Mux-out) (Mux-a))
|
||||
|
||||
(Mux-a-write 1)
|
||||
(Mux-b-write 1)
|
||||
(check-equal? (Mux-out) (Mux-a))
|
||||
|
||||
(Mux-sel-write 1)
|
||||
|
||||
(Mux-a-write 0)
|
||||
(Mux-b-write 0)
|
||||
(check-equal? (Mux-out) (Mux-b))
|
||||
|
||||
(Mux-a-write 0)
|
||||
(Mux-b-write 1)
|
||||
(check-equal? (Mux-out) (Mux-b))
|
||||
|
||||
(Mux-a-write 1)
|
||||
(Mux-b-write 0)
|
||||
(check-equal? (Mux-out) (Mux-b))
|
||||
|
||||
(Mux-a-write 1)
|
||||
(Mux-b-write 1)
|
||||
(check-equal? (Mux-out) (Mux-b))
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
| a | b | sel | out |
|
||||
| 0 | 0 | 0 | 0 |
|
||||
| 0 | 0 | 1 | 0 |
|
||||
| 0 | 1 | 0 | 0 |
|
||||
| 0 | 1 | 1 | 1 |
|
||||
| 1 | 0 | 0 | 1 |
|
||||
| 1 | 0 | 1 | 0 |
|
||||
| 1 | 1 | 0 | 1 |
|
||||
| 1 | 1 | 1 | 1 |
|
||||
|
|
@ -12,12 +12,12 @@
|
|||
*/
|
||||
|
||||
CHIP Mux {
|
||||
IN a, b[15], sel[8];
|
||||
IN a, b, sel;
|
||||
OUT out;
|
||||
|
||||
PARTS:
|
||||
Not(in=sel, out=not-sel);
|
||||
And(a=a, b=not-sel, out=a-and-not-sel);
|
||||
And(a=b, b=sel, out=b-and-sel);
|
||||
Or(a=a-and-not-sel, b=b-and-sel, out=out);
|
||||
// Put your code here:
|
||||
Not(in=sel, out=sel-opposite);
|
||||
And(a=a, b=sel-opposite, out=maybe-a);
|
||||
Or(a=maybe-a, b=b, out=out);
|
||||
}
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
| a | b | sel | out |
|
||||
| 0 | 0 | 0 | 0 |
|
||||
| 0 | 0 | 1 | 0 |
|
||||
| 0 | 1 | 0 | 0 |
|
||||
| 0 | 1 | 1 | 1 |
|
||||
| 1 | 0 | 0 | 1 |
|
||||
| 1 | 0 | 1 | 0 |
|
||||
| 1 | 1 | 0 | 1 |
|
||||
| 1 | 1 | 1 | 1 |
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
// This file is part of www.nand2tetris.org
|
||||
// and the book "The Elements of Computing Systems"
|
||||
// by Nisan and Schocken, MIT Press.
|
||||
// File name: projects/01/Mux.tst
|
||||
|
||||
load Mux.hdl,
|
||||
output-file Mux.out,
|
||||
compare-to Mux.cmp,
|
||||
output-list a%B3.1.3 b%B3.1.3 sel%B3.1.3 out%B3.1.3;
|
||||
|
||||
set a 0,
|
||||
set b 0,
|
||||
set sel 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel 1,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 0,
|
||||
set b 1,
|
||||
set sel 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel 1,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 1,
|
||||
set b 0,
|
||||
set sel 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel 1,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 1,
|
||||
set b 1,
|
||||
set sel 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set sel 1,
|
||||
eval,
|
||||
output;
|
||||
|
|
@ -1,13 +1,14 @@
|
|||
#lang br/demo/hdl-tst
|
||||
#lang br/demo/hdl/tst
|
||||
// This file is part of www.nand2tetris.org
|
||||
// and the book "The Elements of Computing Systems"
|
||||
// by Nisan and Schocken, MIT Press.
|
||||
// File name: projects/01/Mux.tst
|
||||
|
||||
load Mux.hdl,
|
||||
output-file Mux.out,
|
||||
compare-to Mux.cmp,
|
||||
output-list a%B3.1.3 b%B3.1.3 sel%B3.1.3 out%B3.1.3;
|
||||
// output-file Mux.out,
|
||||
// compare-to Mux.cmp,
|
||||
// output-list a%B3.1.3 b%B3.1.3 sel%B3.1.3 out%B3.1.3;
|
||||
output-list a, b, sel, out;
|
||||
|
||||
set a 0,
|
||||
set b 0,
|
||||
|
|
|
|||
13
beautiful-racket/br/demo/hdl/Nand.hdl
Normal file
13
beautiful-racket/br/demo/hdl/Nand.hdl
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
#lang br
|
||||
|
||||
(define+provide (Nand #:a a #:b b)
|
||||
(if (< (+ a b) 2)
|
||||
1
|
||||
0))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-equal? (Nand #:a 0 #:b 0) 1)
|
||||
(check-equal? (Nand #:a 0 #:b 1) 1)
|
||||
(check-equal? (Nand #:a 1 #:b 0) 1)
|
||||
(check-equal? (Nand #:a 1 #:b 1) 0))
|
||||
|
|
@ -1,18 +0,0 @@
|
|||
#lang br
|
||||
(provide (prefix-out Nand- (all-defined-out)))
|
||||
(require "bus.rkt")
|
||||
|
||||
(define-input-bus a)
|
||||
(define-input-bus b)
|
||||
|
||||
(define (out . etc)
|
||||
(if (< (+ (a) (b)) 2)
|
||||
1
|
||||
0))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-equal? (begin (a-write 0) (b-write 0) (out)) 1)
|
||||
(check-equal? (begin (a-write 0) (b-write 1) (out)) 1)
|
||||
(check-equal? (begin (a-write 1) (b-write 0) (out)) 1)
|
||||
(check-equal? (begin (a-write 1) (b-write 1) (out)) 0))
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
#lang br/demo/hdl-tst
|
||||
#lang br/demo/hdl/tst
|
||||
|
||||
/* nand */
|
||||
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
#lang br
|
||||
(provide (prefix-out Nand2- (all-defined-out)))
|
||||
(require "helper.rkt")
|
||||
(define a (make-input))
|
||||
(define b (make-input))
|
||||
|
||||
|
||||
(define (out)
|
||||
(if (< (+ (a) (b)) 2)
|
||||
1
|
||||
0))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-equal? (begin (a 0) (b 0) (out)) 1)
|
||||
(check-equal? (begin (a 0) (b 1) (out)) 1)
|
||||
(check-equal? (begin (a 1) (b 0) (out)) 1)
|
||||
(check-equal? (begin (a 1) (b 1) (out)) 0))
|
||||
|
||||
#;(define n (make-Nand))
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
#lang s-exp br/demo/hdl/expander
|
||||
|
||||
#|
|
||||
CHIP Not {
|
||||
IN in;
|
||||
OUT out;
|
||||
|
||||
PARTS:
|
||||
Nand(a=in, b=in, out=out);
|
||||
}
|
||||
|#
|
||||
|
||||
(chip-program Not
|
||||
(in-spec (in))
|
||||
(out-spec (out))
|
||||
(part Nand (a in) (b in) (out out)))
|
||||
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
| in | out |
|
||||
| 0 | 1 |
|
||||
| 1 | 0 |
|
||||
13
beautiful-racket/br/demo/hdl/Not.hdl
Normal file
13
beautiful-racket/br/demo/hdl/Not.hdl
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
#lang br/demo/hdl
|
||||
|
||||
CHIP Not {
|
||||
IN in;
|
||||
OUT out;
|
||||
|
||||
PARTS:
|
||||
Nand(a=in, b=in, out=out);
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
#lang br/demo/hdl
|
||||
|
||||
CHIP Not {
|
||||
IN in;
|
||||
OUT out;
|
||||
|
||||
PARTS:
|
||||
Nand(a=in, b=in, out=out);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
| in | out |
|
||||
| 0 | 1 |
|
||||
| 1 | 0 |
|
||||
10
beautiful-racket/br/demo/hdl/Not.tst
Normal file
10
beautiful-racket/br/demo/hdl/Not.tst
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
#lang br/demo/hdl/tst
|
||||
|
||||
/* Not */
|
||||
|
||||
load Not.hdl,
|
||||
output-list in, out;
|
||||
set in 0,
|
||||
eval, output;
|
||||
set in 1,
|
||||
eval, output;
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
#lang s-exp br/demo/hdl-tst/expander
|
||||
|
||||
|
||||
#|
|
||||
load Not.hdl,
|
||||
output-file Not.out,
|
||||
compare-to Not.cmp,
|
||||
output-list in%B3.1.3 out%B3.1.3;
|
||||
set in 0,
|
||||
eval,
|
||||
output;
|
||||
set in 1,
|
||||
eval,
|
||||
output;
|
||||
|
||||
|#
|
||||
|
||||
(require br/demo/hdl-tst/hdlprint rackunit racket/file)
|
||||
(require "Not.hdl.rkt") ; load Not.hdl,
|
||||
(define of (open-output-file "Not.out" #:mode 'text #:exists 'replace)) ; output-file Not.out,
|
||||
(define (output in out) ; output-list in%B3.1.3 out%B3.1.3;
|
||||
(fprintf of (format "~a\n" (string-join (list (hdlprint in "%B3.1.3") (hdlprint out "%B3.1.3")) "|" #:before-first "|" #:after-last "|"))))
|
||||
(define eval-result #f)
|
||||
(define eval-thunk (λ () (list (Not-in) (Not-out)))) ; output-list in%B3.1.3 out%B3.1.3;
|
||||
(output "in" "out") ; put names at top of output
|
||||
(Not-in-write 0) ; set in 0,
|
||||
(set! eval-result (eval-thunk)) ; eval,
|
||||
(apply output eval-result) ; output;
|
||||
(Not-in-write 1) ; set in 1,
|
||||
(set! eval-result (eval-thunk)) ; eval,
|
||||
(apply output eval-result) ; output;
|
||||
(close-output-port of)
|
||||
(display (file->string "Not.out"))
|
||||
(check-equal? (file->lines "Not.out") (file->lines "Not.cmp")) ; compare-to Not.cmp,
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
#lang br/demo/hdl-tst
|
||||
|
||||
load Not.hdl,
|
||||
output-file Not.out,
|
||||
compare-to Not.cmp,
|
||||
output-list in%B3.1.3 out%B3.1.3;
|
||||
|
||||
set in 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set in 1,
|
||||
eval,
|
||||
output;
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
| a | b | out |
|
||||
| 0 | 0 | 0 |
|
||||
| 0 | 1 | 1 |
|
||||
| 1 | 0 | 1 |
|
||||
| 1 | 1 | 1 |
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
| a | b | out |
|
||||
| 0 | 0 | 0 |
|
||||
| 0 | 1 | 1 |
|
||||
| 1 | 0 | 1 |
|
||||
| 1 | 1 | 1 |
|
||||
43
beautiful-racket/br/demo/hdl/Or.tst
Executable file → Normal file
43
beautiful-racket/br/demo/hdl/Or.tst
Executable file → Normal file
|
|
@ -1,29 +1,14 @@
|
|||
// This file is part of www.nand2tetris.org
|
||||
// and the book "The Elements of Computing Systems"
|
||||
// by Nisan and Schocken, MIT Press.
|
||||
// File name: projects/01/Or.tst
|
||||
|
||||
load Or.hdl,
|
||||
output-file Or.out,
|
||||
compare-to Or.cmp,
|
||||
output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
|
||||
|
||||
set a 0,
|
||||
set b 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 0,
|
||||
set b 1,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 1,
|
||||
set b 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 1,
|
||||
set b 1,
|
||||
eval,
|
||||
output;
|
||||
#lang br/demo/hdl/tst
|
||||
|
||||
/* or */
|
||||
|
||||
load Or.hdl,
|
||||
output-list a, b, out;
|
||||
set a 0, set b 0,
|
||||
eval, output;
|
||||
set a 0, set b 1,
|
||||
eval, output;
|
||||
set a 1, set b 0,
|
||||
eval, output;
|
||||
set a 1, set b 1,
|
||||
eval, output;
|
||||
|
|
|
|||
|
|
@ -1,30 +0,0 @@
|
|||
#lang br/demo/hdl-tst
|
||||
// This file is part of www.nand2tetris.org
|
||||
// and the book "The Elements of Computing Systems"
|
||||
// by Nisan and Schocken, MIT Press.
|
||||
// File name: projects/01/Or.tst
|
||||
|
||||
load Or.hdl,
|
||||
output-file Or.out,
|
||||
compare-to Or.cmp,
|
||||
output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
|
||||
|
||||
set a 0,
|
||||
set b 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 0,
|
||||
set b 1,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 1,
|
||||
set b 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 1,
|
||||
set b 1,
|
||||
eval,
|
||||
output;
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
#lang br/demo/hdl
|
||||
|
||||
CHIP And {
|
||||
IN a, b;
|
||||
OUT out;
|
||||
|
||||
PARTS:
|
||||
Nand(a=a, b=b, out=nandout);
|
||||
Not(in=nandout, out=out);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
| a | b | out |
|
||||
| 0 | 0 | 0 |
|
||||
| 0 | 1 | 1 |
|
||||
| 1 | 0 | 1 |
|
||||
| 1 | 1 | 0 |
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
| a | b | out |
|
||||
| 0 | 0 | 0 |
|
||||
| 0 | 1 | 1 |
|
||||
| 1 | 0 | 1 |
|
||||
| 1 | 1 | 0 |
|
||||
41
beautiful-racket/br/demo/hdl/Xor.tst
Executable file → Normal file
41
beautiful-racket/br/demo/hdl/Xor.tst
Executable file → Normal file
|
|
@ -1,29 +1,12 @@
|
|||
// This file is part of www.nand2tetris.org
|
||||
// and the book "The Elements of Computing Systems"
|
||||
// by Nisan and Schocken, MIT Press.
|
||||
// File name: projects/01/Xor.tst
|
||||
|
||||
load Xor.hdl,
|
||||
output-file Xor.out,
|
||||
compare-to Xor.cmp,
|
||||
output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
|
||||
|
||||
set a 0,
|
||||
set b 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 0,
|
||||
set b 1,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 1,
|
||||
set b 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 1,
|
||||
set b 1,
|
||||
eval,
|
||||
output;
|
||||
#lang br/demo/hdl/tst
|
||||
|
||||
load Xor.hdl,
|
||||
output-list a, b, out;
|
||||
set a 0, set b 0,
|
||||
eval, output;
|
||||
set a 0, set b 1,
|
||||
eval, output;
|
||||
set a 1, set b 0,
|
||||
eval, output;
|
||||
set a 1, set b 1,
|
||||
eval, output;
|
||||
|
|
|
|||
|
|
@ -1,31 +0,0 @@
|
|||
#lang br/demo/hdl-tst
|
||||
|
||||
// This file is part of www.nand2tetris.org
|
||||
// and the book "The Elements of Computing Systems"
|
||||
// by Nisan and Schocken, MIT Press.
|
||||
// File name: projects/01/Xor.tst
|
||||
|
||||
load Xor.hdl,
|
||||
output-file Xor.out,
|
||||
compare-to Xor.cmp,
|
||||
output-list a%B3.1.3 b%B3.1.3 out%B3.1.3;
|
||||
|
||||
set a 0,
|
||||
set b 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 0,
|
||||
set b 1,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 1,
|
||||
set b 0,
|
||||
eval,
|
||||
output;
|
||||
|
||||
set a 1,
|
||||
set b 1,
|
||||
eval,
|
||||
output;
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
#lang br
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-values (bus bus? bus-get)
|
||||
(make-impersonator-property 'bus))
|
||||
|
||||
(define-values (output-bus output-bus? output-bus-get)
|
||||
(make-impersonator-property 'output-bus))
|
||||
|
||||
(define-values (input-bus input-bus? input-bus-get)
|
||||
(make-impersonator-property 'input-bus))
|
||||
|
|
@ -1,257 +0,0 @@
|
|||
#lang br
|
||||
(require racket/list (for-syntax br/syntax) racket/splicing "bus-properties.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
(module+ test
|
||||
(require rackunit))
|
||||
|
||||
(define (bitwise-bit-set x bit)
|
||||
(if (not (bitwise-bit-set? x bit))
|
||||
(bitwise-ior x (expt 2 bit))
|
||||
x))
|
||||
|
||||
(define (bitwise-bit-unset x bit)
|
||||
(if (bitwise-bit-set? x bit)
|
||||
(bitwise-and x (bitwise-not (expt 2 bit)))
|
||||
x))
|
||||
|
||||
(module+ test
|
||||
(define x-bitset (string->number "1011" 2)) ; decimal 11
|
||||
(check-true (bitwise-bit-set? x-bitset 0))
|
||||
(check-true (bitwise-bit-set? x-bitset 1))
|
||||
(check-false (bitwise-bit-set? x-bitset 2))
|
||||
(check-true (bitwise-bit-set? x-bitset 3))
|
||||
(set! x-bitset (bitwise-bit-set x-bitset 2))
|
||||
(check-true (bitwise-bit-set? x-bitset 2))
|
||||
(set! x-bitset (bitwise-bit-unset x-bitset 2))
|
||||
(check-false (bitwise-bit-set? x-bitset 2)))
|
||||
|
||||
(define (bus-range start [finish start])
|
||||
(range start (add1 finish)))
|
||||
|
||||
(define (integer->bitvals int width)
|
||||
(reverse (for/list ([i (in-range width)])
|
||||
(bitwise-bit-field int i (add1 i)))))
|
||||
|
||||
(define max-bus-width 64)
|
||||
(define default-bus-width 1)
|
||||
|
||||
|
||||
(define (check-bit-against-width bus-name bit width)
|
||||
(unless (< bit width)
|
||||
(raise-argument-error bus-name (format "bit less than bus width ~a" width) bit)))
|
||||
|
||||
(define (check-val-against-width bus-name val width)
|
||||
(when (and val (> val (sub1 (expt 2 width))))
|
||||
(raise-argument-error bus-name
|
||||
(format "~a-bit value (0 to ~a inclusive)" width (sub1 (expt 2 width))) val)))
|
||||
|
||||
|
||||
(define (make-bus-reader reader-name width)
|
||||
(define-cases bus-reader-func
|
||||
[(_ id-thunk-val) (bus-reader-func id-thunk-val 0 (sub1 width))]
|
||||
[(_ id-thunk-val bit) (bus-reader-func id-thunk-val bit bit)]
|
||||
[(_ id-thunk-val first-bit last-bit)
|
||||
(unless (<= first-bit last-bit)
|
||||
(raise-argument-error reader-name (format "last bit greater than or equal to first bit ~a" first-bit) last-bit))
|
||||
(check-bit-against-width reader-name first-bit width)
|
||||
(check-bit-against-width reader-name last-bit width)
|
||||
(bitwise-bit-field id-thunk-val first-bit (add1 last-bit))])
|
||||
(procedure-rename bus-reader-func reader-name))
|
||||
|
||||
|
||||
(define (make-bus-writer writer-name width)
|
||||
(define-cases bus-writer-func
|
||||
[(_ id-thunk-val) (raise-argument-error writer-name "new value" empty)]
|
||||
[(_ id-thunk-val new-val-in)
|
||||
(define new-val (cond
|
||||
[(boolean? new-val-in)
|
||||
(if new-val-in (sub1 (expt 2 width)) 0)]
|
||||
[(or (input-bus? new-val-in) (output-bus? new-val-in)) (new-val-in)]
|
||||
[else new-val-in]))
|
||||
(check-val-against-width writer-name new-val width)
|
||||
new-val]
|
||||
[(_ id-thunk-val bit new-val) (bus-writer-func id-thunk-val bit bit new-val)]
|
||||
[(_ id-thunk-val first-bit last-bit new-val-in)
|
||||
(define bit-range-width (add1 (- last-bit first-bit)))
|
||||
(define new-val (cond
|
||||
[(boolean? new-val-in)
|
||||
(if new-val-in (sub1 (expt 2 bit-range-width)) 0)]
|
||||
[(or (input-bus? new-val-in) (output-bus? new-val-in)) (new-val-in)]
|
||||
[else new-val-in]))
|
||||
(unless (<= first-bit last-bit)
|
||||
(raise-argument-error writer-name (format "last bit greater than or equal to first bit ~a" first-bit) last-bit))
|
||||
(check-bit-against-width writer-name first-bit width)
|
||||
(check-bit-against-width writer-name last-bit width)
|
||||
(check-val-against-width writer-name new-val bit-range-width)
|
||||
(define last-val
|
||||
(for/fold ([val id-thunk-val])
|
||||
([bit (in-range first-bit (add1 last-bit))]
|
||||
[new-bit-val (in-list (integer->bitvals new-val bit-range-width))])
|
||||
((if (= 1 new-bit-val) bitwise-bit-set bitwise-bit-unset) val bit)))
|
||||
last-val])
|
||||
bus-writer-func)
|
||||
|
||||
|
||||
#|
|
||||
|
||||
base bus:
|
||||
+ can read all, or bits
|
||||
+ every read invokes a thunk
|
||||
|#
|
||||
|
||||
|
||||
|
||||
(define-macro-cases define-base-bus
|
||||
[(_ ID THUNK) #'(define-base-bus ID THUNK default-bus-width)]
|
||||
[(_ ID THUNK BUS-WIDTH-IN)
|
||||
(with-pattern
|
||||
([ID-THUNK (suffix-id #'ID "-val")]
|
||||
[BUS-TYPE (or (syntax-property caller-stx 'impersonate) #'bus)])
|
||||
#`(splicing-let ([ID-THUNK THUNK]
|
||||
[bus-width BUS-WIDTH-IN])
|
||||
(define ID
|
||||
(begin
|
||||
(unless (<= bus-width max-bus-width)
|
||||
(raise-argument-error 'id (format "bus width <= max width ~a" max-bus-width) bus-width))
|
||||
(impersonate-procedure
|
||||
(let ([reader (make-bus-reader 'id bus-width)])
|
||||
(procedure-rename (λ args (apply reader (ID-THUNK) args)) (string->symbol (format "~a:~a-bit" 'ID bus-width))))
|
||||
#f BUS-TYPE #t)))
|
||||
#,(when (syntax-property caller-stx 'writer)
|
||||
(with-pattern
|
||||
([_id-write (suffix-id #'ID "-write")])
|
||||
#'(define _id-write
|
||||
(let ([writer (make-bus-writer 'id-write bus-width)])
|
||||
(λ args
|
||||
(define result (apply writer (ID-THUNK) args))
|
||||
(set! ID-THUNK (λ () result)))))))))])
|
||||
|
||||
|
||||
(module+ test
|
||||
(define-base-bus bb (λ () #b0110) 4)
|
||||
(check-true (bus? bb))
|
||||
(check-false (input-bus? bb))
|
||||
(check-false (output-bus? bb))
|
||||
(check-exn exn:fail? (λ () (define-base-bus bb (λ () #b0110) 17) bb)) ; exceeds 16-bit width
|
||||
(check-equal? (bb) #b0110)
|
||||
(check-equal? (bb 0) #b0)
|
||||
(check-equal? (bb 1) #b1)
|
||||
(check-equal? (bb 2) #b1)
|
||||
(check-equal? (bb 3) #b0)
|
||||
(check-exn exn:fail? (λ () (bb 5))) ; exceeds bus width
|
||||
(check-equal? (bb 0 1) #b10)
|
||||
(check-equal? (bb 1 2) #b11)
|
||||
(check-equal? (bb 2 3) #b01)
|
||||
(check-exn exn:fail? (λ () (bb 3 2))) ; inverted bus spec
|
||||
(check-exn exn:fail? (λ () (bb 5 10))) ; exceeds bus width
|
||||
)
|
||||
|
||||
|
||||
#|
|
||||
output bus:
|
||||
+ thunk is a runtime computation
|
||||
+ cannot write
|
||||
|#
|
||||
|
||||
|
||||
|
||||
|
||||
(define-macro (define-output-bus . ARGS)
|
||||
(syntax-property #'(define-base-bus . ARGS) 'impersonate #'output-bus))
|
||||
|
||||
(module+ test
|
||||
(define-output-bus ob (λ () #b0110) 4)
|
||||
(check-false (bus? ob))
|
||||
(check-false (input-bus? ob))
|
||||
(check-true (output-bus? ob))
|
||||
(check-exn exn:fail? (λ () (define-base-bus ob (λ () #b0110) 17) ob)) ; exceeds 16-bit width
|
||||
(check-equal? (ob) #b0110)
|
||||
(check-equal? (ob 0) #b0)
|
||||
(check-equal? (ob 1) #b1)
|
||||
(check-equal? (ob 2) #b1)
|
||||
(check-equal? (ob 3) #b0)
|
||||
(check-exn exn:fail? (λ () (ob 5))) ; exceeds bus width
|
||||
(check-equal? (ob 0 1) #b10)
|
||||
(check-equal? (ob 1 2) #b11)
|
||||
(check-equal? (ob 2 3) #b01)
|
||||
(check-exn exn:fail? (λ () (ob 3 2))) ; inverted bus spec
|
||||
(check-exn exn:fail? (λ () (ob 5 10))) ; exceeds bus width
|
||||
)
|
||||
|
||||
#|
|
||||
input bus:
|
||||
+ thunk returns a constant
|
||||
+ identifies itself as input bus
|
||||
+ can write all, or bits
|
||||
|#
|
||||
|
||||
|
||||
(define-macro-cases define-input-bus
|
||||
[(MACRO-NAME ID)
|
||||
#'(MACRO-NAME ID default-bus-width)]
|
||||
[(MACRO-NAME ID BUS-WIDTH)
|
||||
(syntax-property* #'(define-base-bus ID (λ () 0) BUS-WIDTH)
|
||||
['impersonate #'input-bus]
|
||||
['writer #t])])
|
||||
|
||||
(module+ test
|
||||
(define-input-bus ib 4)
|
||||
(check-false (bus? ib))
|
||||
(check-false (output-bus? ib))
|
||||
(check-true (input-bus? ib))
|
||||
(check-exn exn:fail? (λ () (define-input-bus ib 17) ib)) ; exceeds 16-bit width
|
||||
(check-equal? (ib) 0)
|
||||
(ib-write 11) ; set whole value
|
||||
(check-equal? (ib) 11)
|
||||
(check-exn exn:fail? (λ () (ib-write #b11111))) ; overflow
|
||||
(ib-write 2 1) ; set bit
|
||||
(check-equal? (ib) #b1111)
|
||||
(ib-write 0 #b0) ; set bit
|
||||
(ib-write 1 #b0) ; set bit
|
||||
(ib-write 2 #b0) ; set bit
|
||||
(check-equal? (ib) #b1000)
|
||||
(check-exn exn:fail? (λ () (ib-write 5 1 #b0))) ; last index smaller than first
|
||||
(check-exn exn:fail? (λ () (ib-write 1 300 #b0))) ; overlarge bit index
|
||||
(check-exn exn:fail? (λ () (ib-write 300 500 #b0))) ; overlarge bit index
|
||||
(check-exn exn:fail? (λ () (ib-write 1 #b11111))) ; overflow value
|
||||
(ib-write 0)
|
||||
(ib-write 1 2 #b11)
|
||||
(check-equal? (ib) #b0110)
|
||||
(ib-write 3 3 #b1)
|
||||
(ib-write 0 0 #b1)
|
||||
(check-equal? (ib) #b1111)
|
||||
(check-exn exn:fail? (λ () (ib-write 0 300 #b0))) ; overlarge bit index
|
||||
(check-exn exn:fail? (λ () (ib-write 1 1 #b11111))) ; overflow value
|
||||
(ib-write 0)
|
||||
(ib-write 1 2 #t) ; using #t to fill certain bits
|
||||
(check-equal? (ib) #b0110)
|
||||
(ib-write 2 2 #f) ; using #f to fill certain bits
|
||||
(check-equal? (ib) #b0010)
|
||||
(ib-write 0)
|
||||
(ib-write #t) ; using #t to fill all bits
|
||||
(check-equal? (ib) #b1111)
|
||||
(ib-write #f) ; using #f to fill all bits
|
||||
(check-equal? (ib) #b0000)
|
||||
(ib-write 1 #t)
|
||||
(check-equal? (ib) 2)
|
||||
(ib-write 1 #f)
|
||||
(check-equal? (ib) 0)
|
||||
(ib-write 2 1)
|
||||
(check-equal? (ib) 4)
|
||||
(ib-write 2 0)
|
||||
(check-equal? (ib) 0)
|
||||
(ib-write 1 2 #t)
|
||||
(check-equal? (ib) 6)
|
||||
(ib-write 2 3 #t)
|
||||
(check-equal? (ib) 14)
|
||||
(ib-write 0 2 #f)
|
||||
(check-equal? (ib) 8)
|
||||
(ib-write #b1011)
|
||||
(check-equal? (ib) 11)
|
||||
(define-input-bus ib2 4)
|
||||
(check-exn exn:fail? (λ () (ib2-write 16))) ; overflow value
|
||||
(ib2-write #b1100)
|
||||
(ib-write ib2) ; using bus as input value
|
||||
(check-equal? (ib) (ib2))
|
||||
)
|
||||
|
|
@ -1,60 +1,40 @@
|
|||
#lang br/quicklang
|
||||
(require "bus.rkt" (for-syntax racket/syntax racket/require-transform br/syntax "bus-properties.rkt"))
|
||||
(provide #%module-begin (all-defined-out))
|
||||
#lang br
|
||||
(provide #%top-interaction #%module-begin #%app #%datum (all-defined-out))
|
||||
|
||||
(define-macro (chip-program CHIPNAME
|
||||
(in-spec (IN-BUS IN-WIDTH ...) ...)
|
||||
(out-spec (OUT-BUS OUT-WIDTH ...) ...)
|
||||
PART ...)
|
||||
(with-pattern
|
||||
([CHIP-PREFIX (suffix-id #'CHIPNAME "-")]
|
||||
[(IN-BUS-WRITE ...) (suffix-id #'(IN-BUS ...) "-write")]
|
||||
[(PREFIX-OUT-BUS ...) (prefix-id #'CHIP-PREFIX #'(OUT-BUS ...))])
|
||||
#'(begin
|
||||
(provide (prefix-out CHIP-PREFIX (combine-out IN-BUS ... IN-BUS-WRITE ...)))
|
||||
(define-input-bus IN-BUS IN-WIDTH ...) ...
|
||||
PART ...
|
||||
(provide PREFIX-OUT-BUS ...)
|
||||
(define-output-bus PREFIX-OUT-BUS OUT-BUS OUT-WIDTH ...) ...)))
|
||||
(define-inverting #'(chip-program "CHIP" _chipname "{"
|
||||
(_input-pin ...)
|
||||
(_output-pin ...)
|
||||
_part-spec "}")
|
||||
#'(begin
|
||||
(define+provide _chipname
|
||||
(procedure-rename
|
||||
(make-keyword-procedure
|
||||
(λ (kws kw-args . rest)
|
||||
(define kw-pairs (map cons kws kw-args))
|
||||
(let ([_input-pin (cdr (assq (string->keyword (format "~a" '_input-pin)) kw-pairs))] ...)
|
||||
_part-spec
|
||||
(values _output-pin ...)))) '_chipname))))
|
||||
|
||||
(define-inverting #'(pin-spec _label _pin ... ";")
|
||||
#'(_pin ...))
|
||||
|
||||
(define-macro (part PARTNAME ((BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...)
|
||||
(with-pattern
|
||||
([(PARTNAME-BUS-LEFT ...) (prefix-id #'PARTNAME "-" #'(BUS-LEFT ...))]
|
||||
[PARTNAME-MODULE-PATH (format-string "~a.hdl.rkt" #'PARTNAME)])
|
||||
#'(begin
|
||||
(require (import-chip PARTNAME-MODULE-PATH)
|
||||
;; need for-syntax to make phase 1 binding available
|
||||
;; so we can determine during expansion which buses are `input-bus?`
|
||||
;; because the pin-spec syntax is inherently ambiguous
|
||||
(for-syntax (import-chip PARTNAME-MODULE-PATH)))
|
||||
(handle-buses ((PARTNAME-BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...))))
|
||||
(define-cases #'pin
|
||||
[#'(_ _pin ",") #'_pin]
|
||||
[#'(_ _pin) #'_pin])
|
||||
|
||||
(define #'(part-spec "PARTS:" _part ...)
|
||||
#'(begin _part ...))
|
||||
|
||||
(define-syntax import-chip
|
||||
(make-require-transformer
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ module-path)
|
||||
(expand-import #'module-path)]))))
|
||||
(define-inverting #'(part _partname "(" (_pin _val) ... (_lastpin _pinout) ")" ";")
|
||||
#'(define _pinout (call-part _partname [_pin _val] ...)))
|
||||
|
||||
(define-cases #'pin-val-pair
|
||||
[#'(_ _pin "=" _val ",") #'(_pin _val)]
|
||||
[#'(_ _pin "=" _val) #'(_pin _val)])
|
||||
|
||||
(define-macro (handle-buses BUS-ASSIGNMENTS ...)
|
||||
(let-values
|
||||
([(in-bus-assignments out-bus-assignments)
|
||||
(syntax-case-partition #'(BUS-ASSIGNMENTS ...) ()
|
||||
[((PREFIXED-WIRE . _) _)
|
||||
;; we "pre-evaluate" #'PREFIXED-WIRE so we can set up the program correctly.
|
||||
;; This is not ideal: usually we want evaluate runtime expressions only at runtime.
|
||||
;; But in this case, it controls which identifiers we `define` as output buses
|
||||
;; so there's no way around it. Runtime would be too late.
|
||||
(input-bus? (syntax-local-eval #'PREFIXED-WIRE))])])
|
||||
(with-pattern
|
||||
([(((IN-BUS IN-BUS-ARG ...) IN-BUS-VALUE) ...) in-bus-assignments]
|
||||
[(IN-BUS-WRITE ...) (suffix-id #'(IN-BUS ...) "-write")]
|
||||
[((OUT-BUS-EXPR (NEW-OUT-BUS)) ...) out-bus-assignments])
|
||||
#'(begin
|
||||
(define-output-bus NEW-OUT-BUS
|
||||
(λ ()
|
||||
(IN-BUS-WRITE IN-BUS-ARG ... IN-BUS-VALUE) ...
|
||||
OUT-BUS-EXPR)) ...))))
|
||||
(define #'(call-part _partname [_pin _val] ...)
|
||||
(inject-syntax ([#'part-path (format "~a.hdl" (syntax->datum #'_partname))]
|
||||
[#'(kw ...) (map (λ(pi) (string->keyword (format "~a" (syntax->datum pi)))) (syntax->list #'(_pin ...)))])
|
||||
#'(let ()
|
||||
(local-require (rename-in part-path [_partname local-name]))
|
||||
(keyword-apply local-name '(kw ...) (list _val ...) null))))
|
||||
|
|
|
|||
|
|
@ -1,32 +1,21 @@
|
|||
#lang brag
|
||||
|
||||
chip-program : /"CHIP" chipname /"{" in-spec out-spec part-spec /"}"
|
||||
;; rule of thumb: use [optional] bits judiciously as they multiply the cases needed for a production rule
|
||||
;; rule of thumb: for a set of related IDs, put each into the same grammar entity
|
||||
;; rule of thumb: avoid mushing unrelated IDs into one grammar entity
|
||||
;; whereas a * corresponds directly to an ... in the expander macro
|
||||
;; syntax patterns are good for
|
||||
;; + single case / nonrecursive structure
|
||||
;; + nonalternating pattern (no "this that this that ...")
|
||||
|
||||
@chipname : ID
|
||||
chip-program : "CHIP" ID "{" pin-spec pin-spec part-spec "}"
|
||||
|
||||
in-spec : pin-spec
|
||||
pin-spec : ("IN" | "OUT") pin+ ";"
|
||||
|
||||
out-spec : pin-spec
|
||||
pin : ID [","]
|
||||
|
||||
@pin-spec : (/"IN" | /"OUT") pin [/"," pin]* /";"
|
||||
part-spec : "PARTS:" part+
|
||||
|
||||
/pin : ID [/"[" NUMBER /"]"]
|
||||
part : ID "(" pin-val-pair+ ")" ";"
|
||||
|
||||
@part-spec : /"PARTS:" part+
|
||||
|
||||
part : partname /"(" wire-assign [/"," wire-assign]* /")" /";"
|
||||
|
||||
@partname : ID
|
||||
|
||||
/wire-assign : pin-range /"=" pin-val
|
||||
|
||||
/pin-range : ID [/"[" bus-range /"]"]
|
||||
|
||||
@bus-range : number [/"." /"." number]
|
||||
|
||||
@pin-val : pin-range
|
||||
| BINARY-NUMBER
|
||||
| TRUE
|
||||
| FALSE
|
||||
|
||||
@number : BINARY-NUMBER | NUMBER
|
||||
pin-val-pair : ID "=" ID [","]
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
#lang br
|
||||
(require br/reader-utils "parser.rkt" "tokenizer.rkt")
|
||||
|
||||
(define-read-and-read-syntax (source-path input-port)
|
||||
#`(module hdl-mod br/demo/hdl/expander
|
||||
#,(parse source-path (tokenize input-port))))
|
||||
(provide read-syntax)
|
||||
(define (read-syntax source-path input-port)
|
||||
(strip-context #`(module hdl-mod br/demo/hdl/expander
|
||||
#,(parse source-path (tokenize input-port)))))
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user