simplify

beautiful-racket-lib/br/define.rkt

@@ -2,38 +2,87 @@
 (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)))
-
+;; 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"
+    (pattern (syntax thing:expr)))
+  
+  (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 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)))
+  (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"
@@ -41,23 +90,19 @@
   
   (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])
 
-  (check-equal? (op "+") 'got-plus)
-  (check-equal? (op 42) 'got-something-else)
-  
-  (br:define-cases f
-    [(_ arg) (add1 arg)]
-    [(_ arg1 arg2) (+ arg1 arg2)])
+(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)))
 
-  (check-equal? (f 42) 43)
-  (check-equal? (f 42 5) 47))
 
 
 (define-syntax-rule (br:define+provide arg ...)
   (define+provide arg ...)) 
-

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 ...)])
-
-(define-cases #'IF
+  ;[#'(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
@@ -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)

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
 

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))))

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)