sense being made

beautiful-racket/br/demo/basic/expander.rkt

@@ -1,20 +1,26 @@
 #lang br
-(provide (all-defined-out)
+(provide #%top-interaction #%app #%datum
-         #%top-interaction
+         (rename-out [basic-module-begin #%module-begin])
-         #%datum
+         (rename-out [basic-top #%top])
-         (rename-out [basic-module-begin #%module-begin]))
+         (all-defined-out))
-(require (for-syntax racket/string))
+(require (for-syntax racket/syntax))
 
 (define #'(basic-module-begin PARSE-TREE ...)
   #'(#%module-begin
      (println (quote PARSE-TREE ...))
-     'PARSE-TREE ...))
+     PARSE-TREE ...))
 
-(define #'(basic-program LINE ...)
+; #%app and #%datum have to be present to make #%top work
-  #'(basic-run LINE ...))
+(define #'(basic-top . id)
+  #'(begin
+      (displayln (format "got unbound identifier: ~a" 'id))
+      (procedure-rename (λ xs (cons 'id xs)) (format-datum "undefined:~a" 'id))))
+
+(define #'(basic-program CR-LINE ...)
+  #'(begin CR-LINE ...))
 
 (define (basic-run . lines)
-  (define program-lines (list->vector (filter (λ(x) x) lines)))
+  (define program-lines (list->vector lines))
   (void (for/fold ([line-idx 0])
                   ([i (in-naturals)]
                    #:break (= line-idx (vector-length program-lines)))
@@ -28,60 +34,47 @@
                              idx)))
               (add1 line-idx)))))
 
-(define #'(CR) #'#f)
+(define-cases #'cr-line ; erases "cr"s
-
+  [#'(_ "cr" LINE)  #'LINE]
-(define #'(REM ARG ...) #'(void (list 'ARG ...)))
+  [#'(_ "cr") #'(begin)])
-
-;; model each line as (cons line-number line-thunk)
-(define-cases #'line
-  [#'(_ NUMBER . SEPARATED-STMTS)
-   #`(cons NUMBER
-           (λ _ (begin
-                  #,@(for/list ([(item idx) (in-indexed (syntax->list #'SEPARATED-STMTS))]
-                                #:when (even? idx))
-                               item))))]
-  [#'(_ ARG ...) #'(line #f ARG ...)])
-
-(define #'(statement NAME ARG ...) #'(NAME ARG ...))
-
-(define #'(expression ITEM) #'ITEM)
-(define #'(unsignedexpr ITEM) #'ITEM)
-(define #'(term ITEM) #'ITEM)
-(define #'(factor ITEM) #'ITEM)
-(define #'(number ITEM) #'ITEM)
-(define #'(varlist ITEM) #'ITEM)
-(define #'(var ITEM) #'ITEM)
-
 
-(define #'(printitem EXPR-OR-STRING) #'EXPR-OR-STRING)
+(define #'(line NUMBER STATEMENT ...)
+  #'(begin STATEMENT ...))
 
-;; skip separators
+(define-cases #'statement
-(define #'(printlist . SEPARATED-ITEMS) #`(list #,@(for/list ([(item idx) (in-indexed (syntax->list #'SEPARATED-ITEMS))]
+  [#'(statement ID "=" EXPR) (if (identifier-binding #'ID)
-                                                              #:when (even? idx))
+                                 #'(set! ID EXPR)
-                                                             item)))
+                                 #'(define ID EXPR))]
+  [#'(statement PROC ARG ...) #'(PROC ARG ...)])
 
-(define #'(separator SEP) #'(void))
+(define-cases #'value
+  [#'(value "(" EXPR ")") #'EXPR]
+  [#'(value ID "(" ARG ... ")") #'(ID ARG ...)]
+  [#'(value DATUM) #'DATUM])
 
-(define #'(function NAME EXP ")") #`(#,(string->symbol (string-trim (syntax->datum #'NAME) "(")) EXP))
+(define #'(expr EXPR) #'EXPR)
 
-(define (TAB expr)
+(define-cases sum
-  (make-string expr #\space))
+  [(_ term op sum) (op term sum)]
+  [(_ term) term])
+(provide - +)
 
-(define (PRINT . args)
+(define-cases product
-  (println args)
+  [(_ factor op product) (op factor product)]
-  (if (and (= (length args) 1) (list? (car args)))
+  [(_ factor) factor])
-      (begin
+(provide * /)
-        (for-each display (car args))
-        (displayln ""))
-      (filter (λ(i) (and (equal? i ":") (displayln ""))) args)))
 
-(define (GOTO where)
+(define print-list list)
-  where)
 
-(define vars (make-hasheq))
+(define (PRINT args)
-(define (INPUT id)
+  (match args
-  (hash-set! vars (string->symbol id) (read (open-input-string (read-line)))))
+    [(list) (displayln "")]
+    [(list items ... ";" pl) (begin (for-each display items) (PRINT pl))]
+    [(list items ... ";") (for-each display items)]
+    [(list items ...) (for-each displayln items)]))
 
-(define-cases #'expr-list
+(define (TAB num) (make-string num #\space))
-  [#'(_ EXPR ...) #'(list EXPR ...)])
+(define (INT num) (inexact->exact (round num)))
+(define (SIN num) (sin num))
 
+(define (comment . args) void)

beautiful-racket/br/demo/basic/expander0.rkt

@@ -0,0 +1,87 @@
+#lang br
+(provide (all-defined-out)
+         #%top-interaction
+         #%datum
+         (rename-out [basic-module-begin #%module-begin]))
+(require (for-syntax racket/string))
+
+(define #'(basic-module-begin PARSE-TREE ...)
+  #'(#%module-begin
+     (println (quote PARSE-TREE ...))
+     'PARSE-TREE ...))
+
+(define #'(basic-program LINE ...)
+  #'(basic-run LINE ...))
+
+(define (basic-run . lines)
+  (define program-lines (list->vector (filter (λ(x) x) lines)))
+  (void (for/fold ([line-idx 0])
+                  ([i (in-naturals)]
+                   #:break (= line-idx (vector-length program-lines)))
+          (match-define (cons line-number proc)
+            (vector-ref program-lines line-idx))
+          (define maybe-jump-number (and proc (proc)))
+          (if (number? maybe-jump-number)
+              (let ([jump-number maybe-jump-number])
+                (for/or ([idx (in-range (vector-length program-lines))])
+                        (and (= (car (vector-ref program-lines idx)) jump-number)
+                             idx)))
+              (add1 line-idx)))))
+
+(define #'(CR) #'#f)
+
+(define #'(REM ARG ...) #'(void (list 'ARG ...)))
+
+;; model each line as (cons line-number line-thunk)
+(define-cases #'line
+  [#'(_ NUMBER . SEPARATED-STMTS)
+   #`(cons NUMBER
+           (λ _ (begin
+                  #,@(for/list ([(item idx) (in-indexed (syntax->list #'SEPARATED-STMTS))]
+                                #:when (even? idx))
+                               item))))]
+  [#'(_ ARG ...) #'(line #f ARG ...)])
+
+(define #'(statement NAME ARG ...) #'(NAME ARG ...))
+
+(define #'(expression ITEM) #'ITEM)
+(define #'(unsignedexpr ITEM) #'ITEM)
+(define #'(term ITEM) #'ITEM)
+(define #'(factor ITEM) #'ITEM)
+(define #'(number ITEM) #'ITEM)
+(define #'(varlist ITEM) #'ITEM)
+(define #'(var ITEM) #'ITEM)
+
+
+(define #'(printitem EXPR-OR-STRING) #'EXPR-OR-STRING)
+
+;; skip separators
+(define #'(printlist . SEPARATED-ITEMS) #`(list #,@(for/list ([(item idx) (in-indexed (syntax->list #'SEPARATED-ITEMS))]
+                                                              #:when (even? idx))
+                                                             item)))
+
+(define #'(separator SEP) #'(void))
+
+(define #'(function NAME EXP ")") #`(#,(string->symbol (string-trim (syntax->datum #'NAME) "(")) EXP))
+
+(define (TAB expr)
+  (make-string expr #\space))
+
+(define (PRINT . args)
+  (println args)
+  (if (and (= (length args) 1) (list? (car args)))
+      (begin
+        (for-each display (car args))
+        (displayln ""))
+      (filter (λ(i) (and (equal? i ":") (displayln ""))) args)))
+
+(define (GOTO where)
+  where)
+
+(define vars (make-hasheq))
+(define (INPUT id)
+  (hash-set! vars (string->symbol id) (read (open-input-string (read-line)))))
+
+(define-cases #'expr-list
+  [#'(_ EXPR ...) #'(list EXPR ...)])
+

beautiful-racket/br/demo/basic/parser.rkt

@@ -1,62 +1,32 @@
 #lang ragg
-;; adapted from http://www.ittybittycomputers.com/IttyBitty/TinyBasic/TBuserMan.txt
 
-;; MS Basic extensions
+basic-program : cr-line* [CR]
-;; http://www.atariarchives.org/basicgames/showpage.php?page=i12
 
-;; games
+cr-line : CR line [cr-line]
-;; http://www.vintage-basic.net/games.html
 
-;; chipmunk basic
+line: INTEGER statement+
-;; http://www.nicholson.com/rhn/basic/basic.man.html
 
-basic-program : [CR] lines [CR]
+statement : "END"
-
-lines : INTEGER statements [CR | CR lines]
-
-statements : statement [":" statements]
-
-statement : "CLOSE" "#" INTEGER
-| "END"
 | "FOR" ID "=" expr "TO" expr ["STEP" expr]     
 | "GOTO" expr
 | "IF" expr "THEN" (statement | expr) ; change: add expr
-| "INPUT" id-list
+| "INPUT" ID+
 | ["LET"] ID "=" expr ; change: make "LET" opt
-| "NEXT" id-list
+| "NEXT" ID+
-| "PRINT" printlist
+| "PRINT" print-list
-| "REM" STRING
+| REM-COMMENT
-
-id-list : ID ["," id-list]
-
-value-list : value ["," value-list]
-
-constant-list : constant ["," constant-list]
-
-integer-list : INTEGER ["," integer-list]
-
-expr-list : expr ["," expr-list]
-
-printlist : [expr [";" printlist]]
-
-expr : and-expr ["OR" expr]
-
-and-expr : not-expr ["AND" and-expr]
-
-not-expr : ["NOT"] compare-expr
-
-compare-expr : add-expr [("=" | "<>" | "><" | ">" | ">=" | "<" | "<=") compare-expr]
 
-add-expr : mult-expr [("+" | "-") add-expr]
+print-list : [expr [";" [print-list]*]]
 
-mult-expr : negate-expr [("*" | "/") mult-expr]
+expr : sum [("=" | "<>" | "><" | ">" | ">=" | "<" | "<=") expr]
 
-negate-expr : ["-"] power-expr
+sum : product [("+" | "-") sum]+
 
-power-expr : [power-expr "^"] value
+product : value [("*" | "/") product]+
 
 value : "(" expr ")"
-| ID ["(" expr-list ")"]
+| ID ["(" expr* ")"]
-| constant
+| INTEGER
+| STRING
+| REAL
 
-constant : INTEGER | STRING | REAL

beautiful-racket/br/demo/basic/parser0.rkt

@@ -0,0 +1,61 @@
+#lang ragg
+;; adapted from http://www.ittybittycomputers.com/IttyBitty/TinyBasic/TBuserMan.txt
+
+;; MS Basic extensions
+;; http://www.atariarchives.org/basicgames/showpage.php?page=i12
+
+;; games
+;; http://www.vintage-basic.net/games.html
+
+;; chipmunk basic
+;; http://www.nicholson.com/rhn/basic/basic.man.html
+
+basic-program : [CR] line [CR line]* [CR]
+
+line: INTEGER statements
+
+statements : statement [":" statement]*
+
+statement : "END"
+| "FOR" ID "=" expr "TO" expr ["STEP" expr]     
+| "GOTO" expr
+| "IF" expr "THEN" (statement | expr) ; change: add expr
+| "INPUT" id-list
+| ["LET"] ID "=" expr ; change: make "LET" opt
+| "NEXT" id-list
+| "PRINT" print-list
+| "REM" STRING
+
+id-list : ID ["," id-list]
+
+;value-list : value ["," value]*
+
+;datum-list : datum ["," datum]*
+
+;integer-list : INTEGER ["," INTEGER]*
+
+expr-list : expr ["," expr]*
+
+print-list : [expr [";" print-list]]
+
+;expr : and-expr ["OR" expr]
+;and-expr : not-expr ["AND" and-expr]
+;not-expr : ["NOT"] compare-expr
+;compare-expr : term [("=" | "<>" | "><" | ">" | ">=" | "<" | "<=") compare-expr]
+
+expr : term [("=" | "<>" | "><" | ">" | ">=" | "<" | "<=") expr]
+
+
+term : factor [("+" | "-") term]
+
+factor : value [("*" | "/") factor]
+
+;negate-expr : ["-"] power-expr
+
+;power-expr : [power-expr "^"] value
+
+value : "(" expr ")"
+| ID ["(" expr-list ")"]
+| datum
+
+datum : INTEGER | STRING | REAL

beautiful-racket/br/demo/basic/sinewave.bas

@@ -1,16 +1,3 @@
 #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
-50 B=0
-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

beautiful-racket/br/demo/basic/tokenizer.rkt

@@ -9,18 +9,26 @@
   (define (next-token)
     (define get-token
       (lexer
-       [(repetition 1 +inf.0 "\n") (token 'CR '(CR))]
+       [(:seq "REM" (repetition 1 +inf.0 (char-complement "\n")))
-       [(union "PRINT" "FOR" "TO" "STEP" "IF" "THEN" "GOTO" "REM"
+        (token 'REM-COMMENT (format-datum '(comment "~v") lexeme))]
+       [(repetition 1 +inf.0 "\n") (token 'CR "cr")]
+       [(union "PRINT" "FOR" "TO" "STEP" "IF" "THEN" "GOTO"
                "INPUT" "LET" "NEXT" "GOSUB" "RETURN"
                "CLEAR" "LIST" "RUN" "END") (string->symbol 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))]
-       [(union "," ";" ":" "+" "-" "*" "/"
+       ;; things that get thrown out: pass through as strings,
-               "<=" ">=" "<>" "><" "<" ">" "=" "(" ")") lexeme]
+       ;; because they can be matched literally in macros.
-       [(:seq (repetition 1 +inf.0 upper-case)) (token 'ID lexeme)]
+       ;; things that become identifiers: pass through as symbols,
-       [upper-case (token 'UPPERCASE lexeme)]
+       ;; so they can get bound by the expander.
+       [(union "," ":") (token 'SEPARATOR lexeme #:skip? #t)]
+       [(union ";" "=" "(" ")") lexeme]
+       [(union "+" "-" "*" "/"
+               "<=" ">=" "<>" "><" "<" ">" "=" ) (string->symbol 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]))