From 7164c4afec54e88ee9c12f4282c63f48958db088 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Fri, 22 Apr 2016 13:28:01 -0700
Subject: [PATCH] simplify
---
beautiful-racket-lib/br/define.rkt | 187 +++++++++++--------
beautiful-racket/br/demo/basic/expander.rkt | 109 ++++++-----
beautiful-racket/br/demo/basic/parser.rkt | 21 +--
beautiful-racket/br/demo/basic/reader.rkt | 5 +-
beautiful-racket/br/demo/basic/tokenizer.rkt | 38 ++--
5 files changed, 197 insertions(+), 163 deletions(-)
diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt
index 9c9ba65..e72b121 100644
--- a/beautiful-racket-lib/br/define.rkt
+++ b/beautiful-racket-lib/br/define.rkt
@@ -2,38 +2,15 @@
(require (for-syntax racket/base syntax/parse racket/syntax syntax/datum syntax/strip-context) sugar/define)
(provide (all-defined-out))
+;; everything is prefixed br: whether it needs it or not so it can be stripped by #lang br
-(define-syntax-rule (br:debug-define (syntax (id pat-arg ... . rest-arg)) body-exp)
- (br:define #'(id pat-arg ... . rest-arg)
- #`(begin
- (for-each displayln
- (list
- (format "input pattern = #'~a" '#,'(id pat-arg ... . rest-arg))
- (format "output pattern = #'~a" (cadr '#,'body-exp))
- (format "invoked as = ~a" (syntax->datum #'(id pat-arg ... . rest-arg)))
- (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 (br:define stx)
+;; todo: support `else` case
+(define-syntax (br:define-cases stx)
(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"
@@ -41,23 +18,91 @@
(syntax-parse 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 [(syntax pat) body ...] ...+)
+ #'(define-syntax top-id.name (λ (stx)
+ (define result
+ (syntax-case stx ()
+ [pat body ...] ...
+ [else (raise-syntax-error 'define-cases (format "no matching case for syntax pattern `~a`" (syntax->datum stx)) (syntax->datum #'top-id.name))]))
+ (if (not (syntax? result))
+ (datum->syntax stx result)
+ result)))]
+
+ ;; function matcher
+ [(_ top-id:id [(_ pat-arg ... . rest-arg) body ...] ...)
+ #'(define top-id
+ (case-lambda
+ [(pat-arg ... . rest-arg) body ...] ...
+ [else (raise-syntax-error 'define-cases "no matching case for argument pattern" (object-name top-id))]))]))
+
+(module+ test
+ (require rackunit)
+ (define foo-val 'got-foo-val)
+ (define (foo-func) 'got-foo-func)
+ (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)
+
+ (br:define-cases f
+ [(_ arg) (add1 arg)]
+ [(_ arg1 arg2) (+ arg1 arg2)])
+
+ (check-equal? (f 42) 43)
+ (check-equal? (f 42 5) 47)
+
+ ;; todo: error from define-cases not trapped by check-exn
+ ;;(check-exn exn:fail:syntax? (λ _ (define-cases (#'times stx stx2) #'*)))
+
+ )
+
+
+
+(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-arg ... . rest-arg)) body ...) ; (define #'(foo arg) #'(+ arg arg))
- #'(define-syntax id (λ (stx)
- (define result
- (syntax-case stx ()
- [(_ pat-arg ... . rest-arg) body ...]))
- (if (not (syntax? result))
- (datum->syntax stx result)
- result)))]
+ #'(br:define-cases (syntax id) [(syntax (_ pat-arg ... . rest-arg)) body ...])]
[(_ sid:syntaxed-id sid2:syntaxed-id) ; (define #'f1 #'f2)
- #'(define-syntax sid.name (make-rename-transformer sid2))]
-
- [(_ sid:syntaxed-id sid2:syntaxed-thing) ; (define #'f1 #'42)
- #'(define-syntax sid.name (λ (stx) sid2))]
+ #'(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 ...) expr ...) ; (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))]
+ (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 ...) expr ...)) ; (define #'f1 (λ(stx) expr ...)
#:fail-when (not (= (length (syntax->datum #'(stx-arg ...))) 1))
@@ -69,63 +114,53 @@
(module+ test
(require rackunit)
(br:define #'plus (λ(stx) #'+))
- (br:define #'plusser #'plus)
- (br:define #'(times arg) #'(* arg arg))
- (br:define #'timeser #'times)
- (br:define #'fortytwo #'42)
(check-equal? (plus 42) +)
- (check-equal? plusser +)
+ (br:define #'plusser #'plus)
(check-equal? (plusser 42) +)
+ (check-equal? plusser +)
+ (br:define #'(times arg) #'(* arg arg))
(check-equal? (times 10) 100)
+ (br:define #'timeser #'times)
(check-equal? (timeser 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)
;; todo: error from define not trapped by check-exn
#;(check-exn exn:fail:syntax? (λ _ (br:define (#'times stx stx2) #'*)))
- (check-equal? fortytwo 42)
(begin
(br:define #'(redefine ID) #'(define ID 42))
(redefine zoombar)
(check-equal? zoombar 42)))
-;; todo: support `else` case
-(define-syntax (br:define-cases stx)
- (syntax-parse stx
- #:literals (syntax)
- ; (define-cases #'foo [#'(_ arg) #'(+ arg arg)] [#'(_ 42 bar) #'42] ...)
- [(_ (syntax top-id) [(syntax (_ pat-arg ... . rest-arg)) body ...] ...)
- #'(define-syntax top-id (λ (stx)
- (define result
- (syntax-case stx ()
- [(_ pat-arg ... . rest-arg) body ...] ...))
- (if (not (syntax? result))
- (datum->syntax stx result)
- result)))]
-
- [(_ top-id [(_ pat-arg ... . rest-arg) body ...] ...)
- #'(define top-id
- (case-lambda
- [(pat-arg ... . rest-arg) body ...] ...))]))
+(define-syntax-rule (br:debug-define (syntax (id pat-arg ... . rest-arg)) body-exp)
+ (br:define #'(id pat-arg ... . rest-arg)
+ #`(begin
+ (for-each displayln
+ (list
+ (format "input pattern = #'~a" '#,'(id pat-arg ... . rest-arg))
+ (format "output pattern = #'~a" (cadr '#,'body-exp))
+ (format "invoked as = ~a" (syntax->datum #'(id pat-arg ... . rest-arg)))
+ (format "expanded as = ~a" '#,(syntax->datum body-exp))
+ (format "evaluated as = ~a" #,body-exp)))
+ #,body-exp)))
+
(module+ test
- (br:define-cases #'op
- [#'(_ "+") #''got-plus]
- [#'(_ arg) #''got-something-else])
+ (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)))
- (check-equal? (op "+") 'got-plus)
- (check-equal? (op 42) 'got-something-else)
-
- (br:define-cases f
- [(_ arg) (add1 arg)]
- [(_ arg1 arg2) (+ arg1 arg2)])
-
- (check-equal? (f 42) 43)
- (check-equal? (f 42 5) 47))
(define-syntax-rule (br:define+provide arg ...)
(define+provide arg ...))
-
diff --git a/beautiful-racket/br/demo/basic/expander.rkt b/beautiful-racket/br/demo/basic/expander.rkt
index 24c5647..2830953 100644
--- a/beautiful-racket/br/demo/basic/expander.rkt
+++ b/beautiful-racket/br/demo/basic/expander.rkt
@@ -3,7 +3,10 @@
(rename-out [basic-module-begin #%module-begin])
(rename-out [basic-top #%top])
(all-defined-out))
-(require br/stxparam)
+(require br/stxparam (for-syntax br/datum))
+
+; BASIC implementation details
+; http://www.atariarchives.org/basicgames/showpage.php?page=i12
(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$ ""])
@@ -36,16 +39,19 @@
(exn:line-not-found
(format "line number ~a not found in program" ln)
(current-continuation-marks)))))
- (void (with-handlers ([exn:program-end? (λ (exn) (void))])
- (for/fold ([program-counter 0])
- ([i (in-naturals)]
- #:break (= program-counter (vector-length program-lines)))
- (match-define (cons line-number proc)
- (vector-ref program-lines program-counter))
- (define maybe-jump-number (and proc (proc)))
- (if (number? maybe-jump-number)
- (line-number->index maybe-jump-number)
- (add1 program-counter))))))
+ (with-handlers ([exn:program-end? (λ _ (void))])
+ (for/fold ([program-counter 0])
+ ([i (in-naturals)])
+ (cond
+ [(= program-counter (vector-length program-lines)) (basic:END)]
+ [else
+ (match-define (cons line-number proc)
+ (vector-ref program-lines program-counter))
+ (define maybe-jump-number (and proc (proc)))
+ (if (number? maybe-jump-number)
+ (line-number->index maybe-jump-number)
+ (add1 program-counter))])))
+ (void))
(define #'(cr-line ARG ...) #'(begin ARG ...))
@@ -53,7 +59,7 @@
(define current-return-stack (make-parameter empty))
(define-cases #'line
- [#'(_ NUMBER (STATEMENT "GOSUB" WHERE))
+ [#'(_ NUMBER (statement-list (statement "GOSUB" WHERE)))
#'(cons NUMBER
(λ _
(let ([return-stack (current-return-stack)])
@@ -61,16 +67,24 @@
[(or (empty? return-stack)
(not (= NUMBER (car return-stack))))
(current-return-stack (cons NUMBER (current-return-stack)))
- (GOTO WHERE)]
+ (basic:GOTO WHERE)]
[else (current-return-stack (cdr (current-return-stack)))]))))]
- [#'(_ NUMBER STATEMENT ...) #'(cons NUMBER (λ _ STATEMENT ...))])
+ [#'(_ NUMBER STATEMENT-LIST) #'(cons NUMBER (λ _ STATEMENT-LIST))])
+(define-cases #'statement-list
+ [#'(_ STATEMENT) #'(begin STATEMENT)]
+ [#'(_ STATEMENT ":" STATEMENT-LIST) #'(begin STATEMENT STATEMENT-LIST)])
(define-cases #'statement
[#'(statement ID "=" EXPR) #'(set! ID EXPR)]
- [#'(statement PROC ARG ...) #'(PROC ARG ...)])
+ ;[#'(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 #'IF
+(define-cases #'basic:IF
[#'(_ COND "THEN" TRUE-RESULT "ELSE" FALSE-RESULT)
#'(if (true? COND)
TRUE-RESULT
@@ -85,72 +99,65 @@
[#'(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-cases #'expr
- [#'(_ LEXPR "AND" REXPR)
- #'(if (and (true? LEXPR) (true? REXPR)) 1 0)]
- [#'(_ LEXPR "OR" REXPR)
- #'(if (or (true? LEXPR) (true? REXPR)) 1 0)]
- [#'(_ EXPR) #'EXPR])
+ [#'(_ COMP-EXPR "AND" EXPR) #'(basic:and COMP-EXPR EXPR)]
+ [#'(_ COMP-EXPR "OR" EXPR) #'(basic:or COMP-EXPR EXPR)]
+ [#'(_ COMP-EXPR) #'COMP-EXPR])
(define-cases #'comp-expr
- [#'(_ lexpr "=" rexpr) #'(comp-expr lexpr equal? rexpr)] ; special case because = is overloaded
- [#'(_ lexpr op rexpr) #'(if (op lexpr rexpr) 1 0)]
+ [#'(_ 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)))]
[#'(_ expr) #'expr])
-(define (<> lexpr rexpr) (not (equal? lexpr rexpr)))
-(provide < > <= >= <>)
+(define <> (compose1 not equal?))
-(define-cases sum
- [(_ term op sum) (op term sum)]
- [(_ term) term])
-(provide - +)
+(define-cases #'sum
+ [#'(_ term "+" sum) #'(+ term sum)]
+ [#'(_ term "-" sum) #'(- term sum)]
+ [#'(_ term) #'term])
-(define-cases product
- [(_ factor op product) (op factor product)]
- [(_ factor) factor])
-(provide * /)
+(define-cases #'product
+ [#'(_ factor "*" product) #'(* factor product)]
+ [#'(_ factor "/" product) #'(/ factor product)]
+ [#'(_ factor) #'factor])
(define print-list list)
-(define (PRINT args)
+(define (basic:PRINT args)
(match args
[(list) (displayln "")]
[(list print-list-item ... ";" pl) (begin (for-each display print-list-item)
- (display " ")
- (PRINT pl))]
- [(list print-list-item ... ";") (begin
- (for-each display print-list-item)
- (display " "))]
+ (print pl))]
+ [(list print-list-item ... ";") (for-each display print-list-item)]
[(list print-list-item ...) (for-each displayln print-list-item)]))
(define (TAB num) (make-string num #\space))
-(define #'(INT EXPR ...) #'(inexact->exact (round (expr EXPR ...))))
+(define #'(INT EXPR ...) #'(inexact->exact (truncate (expr EXPR ...))))
(define (SIN num) (sin num))
(define (ABS num) (inexact->exact (abs num)))
(define (RND num) (* (random) num))
-(define-cases #'INPUT
+(define-cases #'basic:INPUT
[#'(_ PRINT-LIST ";" ID)
#'(begin
- (PRINT (append PRINT-LIST (list ";")))
- (INPUT ID))]
+ (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 (GOTO where)
- where)
+(define (basic:GOTO where) where)
-(define (RETURN)
- (car (current-return-stack)))
+(define (basic:RETURN) (car (current-return-stack)))
(struct exn:program-end exn:fail ())
-(define (END)
+(define (basic:END)
(raise
(exn:program-end
"program ended"
(current-continuation-marks))))
-
-
-(define (comment . args) void)
diff --git a/beautiful-racket/br/demo/basic/parser.rkt b/beautiful-racket/br/demo/basic/parser.rkt
index 3634c1d..421dcad 100644
--- a/beautiful-racket/br/demo/basic/parser.rkt
+++ b/beautiful-racket/br/demo/basic/parser.rkt
@@ -1,21 +1,20 @@
#lang ragg
;; recursive rules destucture easily in the expander
-program : [line [CR line]*]
+program : [CR]* [line [CR line]*] [CR]*
-line: INTEGER statement+
+line: NUMBER statement-list
+
+statement-list : statement [":" statement-list]
statement : "END"
-| "FOR" ID "=" expr "TO" expr ["STEP" expr]
-| "GOSUB" INTEGER
+| "GOSUB" NUMBER
| "GOTO" expr
-| "IF" expr "THEN" (statement | expr) ["ELSE" (statement | expr)]; change: add expr
+| "IF" expr "THEN" (statement | expr) ["ELSE" (statement | expr)]
| "INPUT" [print-list ";"] ID
-| ["LET"] ID "=" expr ; change: make "LET" opt
-| "NEXT" ID+
+| ID "=" expr ; change: make "LET" opt
| "PRINT" print-list
| "RETURN"
-| REM-COMMENT
print-list : [expr [";" [print-list]]]
@@ -28,9 +27,7 @@ sum : product [("+" | "-") sum]
product : value [("*" | "/") product]
value : "(" expr ")"
-| ID
-| PROC "(" expr* ")"
-| INTEGER
+| ID ["(" expr* ")"]
| STRING
-| REAL
+| NUMBER
diff --git a/beautiful-racket/br/demo/basic/reader.rkt b/beautiful-racket/br/demo/basic/reader.rkt
index 699e020..f48cba5 100644
--- a/beautiful-racket/br/demo/basic/reader.rkt
+++ b/beautiful-racket/br/demo/basic/reader.rkt
@@ -2,6 +2,5 @@
(require br/reader-utils "parser.rkt" "tokenizer.rkt")
(define-read-and-read-syntax (source-path input-port)
- (strip-context
- #`(module bf-mod br/demo/basic/expander
- #,(parse source-path (tokenize (open-input-string (string-trim (port->string input-port))))))))
+ #`(module bf-mod br/demo/basic/expander
+ #,(parse source-path (tokenize input-port))))
diff --git a/beautiful-racket/br/demo/basic/tokenizer.rkt b/beautiful-racket/br/demo/basic/tokenizer.rkt
index 41de900..ab0a086 100644
--- a/beautiful-racket/br/demo/basic/tokenizer.rkt
+++ b/beautiful-racket/br/demo/basic/tokenizer.rkt
@@ -5,34 +5,30 @@
racket/string)
(provide tokenize)
+(define-lex-abbrevs
+ (natural (repetition 1 +inf.0 numeric))
+ (integer (:seq (:? "-") natural))
+ (number (:seq integer (:? (:seq "." natural))))
+ (quoted-string (:seq "\"" (repetition 0 +inf.0 (char-complement "\"")) "\"")))
+
(define (tokenize input-port)
(define (next-token)
(define get-token
(lexer
- [(:seq "REM" (repetition 1 +inf.0 (char-complement "\n")))
- (token 'REM-COMMENT (format-datum '(comment "~v") lexeme))]
- [(repetition 1 +inf.0 "\n") (token 'CR "cr")]
+ [(eof) eof]
+ [(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") (string->symbol lexeme)]
- [(union "THEN" "ELSE" "GOSUB") lexeme]
-
- ;; this only matches integers
- [(repetition 1 +inf.0 numeric) (token 'INTEGER (string->number lexeme))]
- [(repetition 1 +inf.0 (union "." numeric)) (token 'REAL (string->number lexeme))]
- ;; things that get thrown out: pass through as strings,
- ;; because they can be matched literally in macros.
- ;; things that become identifiers: pass through as symbols,
- ;; so they can get bound by the expander.
- [(union "," ":") (token 'SEPARATOR lexeme #:skip? #t)]
- [(union ";" "=" "(" ")") lexeme]
- [(union "+" "-" "*" "/"
- "<=" ">=" "<>" "><" "<" ">" "=" ) (string->symbol lexeme)]
- [(union "RND" "INT" "TAB" "SIN" "ABS") (token 'PROC (string->symbol lexeme))]
+ "CLEAR" "LIST" "RUN" "END"
+ "THEN" "ELSE" "GOSUB" "AND" "OR"
+ ";" "=" "(" ")" "+" "-" "*" "/"
+ "<=" ">=" "<>" "><" "<" ">" "=" ":") lexeme]
+ [(union ",") (get-token input-port)]
+ [number (token 'NUMBER (string->number lexeme))]
[(:seq (repetition 1 +inf.0 upper-case) (:? "$")) (token 'ID (string->symbol lexeme))]
[upper-case (token 'UPPERCASE (string->symbol lexeme))]
- [whitespace (token 'WHITESPACE lexeme #:skip? #t)]
- [(:seq "\"" (complement (:: any-string "\"" any-string)) "\"") (token 'STRING (string-trim lexeme "\""))]
- [(eof) eof]))
+ [quoted-string (token 'STRING (string-trim lexeme "\""))]))
(get-token input-port))
next-token)