edit basic

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

@@ -1,29 +1,30 @@
 #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 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)
+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))
 110 W=7*A/3
-120 PRINT A;"LITERS OF KRYPTOCYANIC ACID.  HOW MUCH WATER";
-130 INPUT R
+115 if A=1 then P="liter" else P="liters"
+120 print A; " "; P ; " 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=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
+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

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

@@ -3,18 +3,18 @@
          (rename-out [basic-module-begin #%module-begin])
          (rename-out [basic-top #%top])
          (all-defined-out))
-(require br/stxparam (for-syntax br/datum))
+(require br/stxparam)
 
 ; 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$ ""])
 
-(define-macro (basic-module-begin SRC-EXPR ...)
+(define-macro (basic-module-begin . PROGRAM-LINES)
   #'(#%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 SRC-EXPR ...))
-                                SRC-EXPR ...)))
+                                (println (quote . PROGRAM-LINES))
+                                . PROGRAM-LINES)))
 
 ; #%app and #%datum have to be present to make #%top work
 (define-macro (basic-top . ID)
@@ -22,71 +22,71 @@
       (displayln (format "got unbound identifier: ~a" 'ID))
       (procedure-rename (λ xs (cons 'ID xs)) (string->symbol (format "undefined:~a" 'ID)))))
 
-(define-macro (program LINE ...) #'(run (list LINE ...)))
-
+(define-macro (basic-program LINE ...) #'(run (list LINE ...)))
 
 (struct exn:line-not-found exn:fail ())
-(struct exn:program-end 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 exn:program-end exn:fail ())
+(define (raise-program-end-error)
+  (raise (exn:program-end "" (current-continuation-marks))))
 
-(define (run lines)
-  (define program-lines (list->vector (filter (λ(ln) (not (equal? ln "cr"))) lines)))
-  (define (line-number->index ln)
+(define (run line-list)
+  (define lines (list->vector line-list))
+  (define (find-index ln)
     (or
-     (for/or ([idx (in-range (vector-length program-lines))])
-             (and (= (car (vector-ref program-lines idx)) ln)
+     (for/or ([idx (in-range (vector-length lines))])
+             (and (= ($line-number (vector-ref lines idx)) ln)
                   idx))
-     (raise
-      (exn:line-not-found
-       (format "line number ~a not found in program" ln)
-       (current-continuation-marks)))))
-  (with-handlers ([exn:program-end? (λ(exn) (void))])
-    (void
+     (raise-line-not-found-error ln)))
+  (void
+   (with-handlers ([exn:program-end? void])
      (for/fold ([program-counter 0])
                ([i (in-naturals)])
-       (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)]
-            [else (add1 program-counter)])])))))
-
-(define-macro (cr-line ARG ...) #'(begin ARG ...))
-
-
-(define current-return-stack (make-parameter empty))
-
+       (if (= program-counter (vector-length lines))
+           (basic:end)
+           (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))))))))
+
+(define return-stack empty)
+
+(define (do-gosub number where)
+  (if (or (empty? return-stack)
+          (not (= number (car return-stack))))
+      (begin
+        (set! return-stack (cons number return-stack))
+        (basic:goto where))
+      (set! return-stack (cdr return-stack))))
+
+(struct $line (number thunk) #:transparent)
 (define-macro 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 ...) #'(cons NUMBER (λ _ STATEMENT ...))])
-
+  [(_ NUMBER (statement "gosub" WHERE))
+   #'($line NUMBER (λ () (do-gosub NUMBER WHERE)))]
+  [(_ NUMBER . STATEMENTS)
+   #'($line NUMBER (λ () . STATEMENTS))])
 
 (define-macro statement
   [(statement ID "=" EXPR) #'(set! ID EXPR)]
-  [(statement PROC-STRING ARG ...)
+  [(statement PROC-NAME . ARGS)
    (with-pattern
-    ([PROC-ID (prefix-id "basic:" #'PROC-STRING)])
-    #'(PROC-ID ARG ...))])
-
-(define-macro basic:IF
-  [(_ COND "THEN" TRUE-RESULT "ELSE" FALSE-RESULT)
-   #'(if (true? COND)
-         TRUE-RESULT
-         FALSE-RESULT)]
-  [(_ COND "THEN" TRUE-RESULT)
+    ([PROC-ID (prefix-id "basic:" #'PROC-NAME)])
+    #'(PROC-ID . ARGS))])
+
+(define-macro basic:if
+  [(_ COND-EXPR TRUE-EXPR FALSE-EXPR)
+   #'(if (true? COND-EXPR)
+         TRUE-EXPR
+         FALSE-EXPR)]
+  [(_ COND TRUE-EXPR)
    #'(when (true? COND)
-       TRUE-RESULT)])
+       TRUE-EXPR)])
 
 (define true? (compose1 not zero?))
 (define (cond->int cond) (if cond 1 0))
@@ -94,35 +94,38 @@
 (define (basic:or . args) (cond->int (ormap true? args)))
 
 (define-macro expr
+  [(_ COMP-EXPR) #'COMP-EXPR]
   [(_ COMP-EXPR "AND" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)]
-  [(_ COMP-EXPR "OR" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)]
-  [(_ COMP-EXPR) #'COMP-EXPR])
+  [(_ COMP-EXPR "OR" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)])
 
 (define-macro comp-expr
-  [(_ LEXPR "=" REXPR) #'(comp-expr LEXPR "equal?" REXPR)] ; special case because = is overloaded
-  [(_ LEXPR OP-STR REXPR) (with-pattern ([OP (replace-context #'here (prefix-id #'OP-STR))])
-                                        #'(cond->int (OP LEXPR REXPR)))]
-  [(_ ARG) #'ARG])
+  [(_ 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 <> (compose1 not equal?))
 
 (define-macro sum
-  [(_ TERM "+" SUM) #'(+ TERM SUM)]
-  [(_ TERM "-" SUM) #'(- TERM SUM)]
-  [(_ TERM) #'TERM])
+  [(_ SUM) #'SUM]
+  [(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)]
+  [(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)])
 
 (define-macro product
-  [(_ VALUE "*" PRODUCT) #'(* VALUE PRODUCT)]
-  [(_ VALUE "/" PRODUCT) #'(/ VALUE PRODUCT)]
-  [(_ VALUE) #'VALUE])
+  [(_ VALUE) #'VALUE]
+  [(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)]
+  [(_ PRODUCT "/" VALUE) #'(/ PRODUCT VALUE)])
 
 (define print-list list)
 
-(define (basic:PRINT args)
+(define (basic:print [args #f])
   (match args
-    [(list) (displayln "")]
+    [#f (displayln "")]
     [(list print-list-item ... ";" pl) (begin (for-each display print-list-item)
-                                              (basic:PRINT pl))]
+                                              (basic:print pl))]
     [(list print-list-item ... ";") (for-each display print-list-item)]
     [(list print-list-item ...) (for-each displayln print-list-item)]))
 
@@ -132,21 +135,17 @@
 (define (ABS num) (inexact->exact (abs num)))
 (define (RND num) (* (random) num))
 
-(define-macro basic:INPUT
-  [(_ PRINT-LIST ";" _ID)
+(define-macro basic:input
+  [(_ PRINT-LIST _ID)
    #'(begin
-       (basic:PRINT (append PRINT-LIST (list ";")))
-       (basic:INPUT _ID))]
+       (basic:print (append PRINT-LIST (list ";")))
+       (basic:input _ID))]
   [(_ ID) #'(set! ID (let* ([str (read-line)]
                             [num (string->number str)])
                        (or num str)))])
 
-(define (basic:GOTO where) where)
+(define (basic:goto where) where)
 
-(define (basic:RETURN) (car (current-return-stack)))
+(define (basic:return) (car return-stack))
 
-(define (basic:END)
-  (raise
-   (exn:program-end
-    ""
-    (current-continuation-marks))))
+(define (basic:end) (raise-program-end-error))

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

@@ -1,29 +1,30 @@
 #lang brag
 
-program : line*
+basic-program : line*
 
-line: NUMBER statement [":" statement]*
+line: NUMBER statement [/":" statement]*
 
-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"
+statement : "end"
+| "gosub" expr
+| "goto" expr
+| "if" expr /"then" (statement | expr) [/"else" (statement | expr)]
+| "input" [print-list /";"] ID
+| ID "=" expr
+| "print" [print-list]
+| "return"
 
-print-list : [expr [";" [print-list]]]
+print-list : expr [";" [print-list]]
 
 expr : comp-expr [("AND" | "OR") expr]
 
 comp-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") comp-expr]
 
-sum : product [("+" | "-") sum]
+sum : [sum ("+" | "-")] product
 
-product : value [("*" | "/") product]
+product : [product ("*" | "/")] value 
 
-@value : ID | id-expr
+@value : ID
+| id-expr
 | /"(" expr /")"
 | STRING
 | NUMBER

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

@@ -13,16 +13,17 @@
 (define (tokenize input-port)
   (define (next-token)
     (define get-token
-      (lexer
+      (lexer-src-pos
        [(eof) eof]
        [(union #\tab #\space #\newline
                (seq number " REM" (repetition 1 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)]
-       [(union "PRINT" "FOR" "TO" "STEP" "IF" "GOTO"
-               "INPUT" "LET" "NEXT"  "RETURN"
-               "CLEAR" "LIST" "RUN" "END"
-               "THEN" "ELSE" "GOSUB" "AND" "OR"
+       [(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"
                ";" "=" "(" ")" "+" "-" "*" "/"
-               "<=" ">=" "<>" "<" ">" "=" ":") lexeme]
+               "<=" ">=" "<>" "<" ">" "=" ":") (string-downcase lexeme)]
        [(union ",") (get-token input-port)]
        [number (token 'NUMBER (string->number lexeme))]
        [(seq (repetition 1 +inf.0 upper-case) (? "$")) (token 'ID (string->symbol lexeme))]

beautiful-racket/br/demo/bf/bf-reader.rkt

@@ -3,7 +3,7 @@
 (define (tokenize input-port)
   (define (next-token)
     (define get-token
-      (lexer
+      (lexer-src-pos
        [(char-set "><-.,+[]") lexeme]
        [(char-complement (char-set "><-.,+[]")) 
          (token 'OTHER #:skip? #t)]

beautiful-racket/br/demo/hdl-tst/tokenizer.rkt

@@ -7,7 +7,7 @@
 (define (tokenize input-port)
   (define (next-token)
     (define get-token
-      (lexer
+      (lexer-src-pos
        [(eof) eof]
         [(union
          (seq "/*" (complement (seq any-string "*/" any-string)) "*/")

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

@@ -7,7 +7,7 @@
 (define (tokenize input-port)
   (define (next-token)
     (define get-token
-      (lexer
+      (lexer-src-pos
        [(eof) eof]
        [(union
          (seq "/*" (complement (seq any-string "*/" any-string)) "*/")