start basic interpreter

beautiful-racket-lib/br/reader-utils.rkt

@@ -1,5 +1,5 @@
 #lang racket/base
-(require (for-syntax racket/base) 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,
@@ -9,14 +9,20 @@
 (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)])
+                     [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 READ READ-SYNTAX)
+             (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 (READ-SYNTAX path port)
+             (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)])
@@ -26,11 +32,12 @@
                                    ;; 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)) 
+                                   (strip-context result-syntax)) 'READ-SYNTAX)) 
              
-           (define (READ port)
+             (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)))))]))
+                                         output))) 'READ)))))]))

beautiful-racket/br/basic.rkt

@@ -0,0 +1,4 @@
+#lang br
+(module reader br
+  (require br/basic/reader)
+  (provide (all-from-out br/basic/reader)))

beautiful-racket/br/basic/expander.rkt

@@ -0,0 +1,39 @@
+#lang br
+(provide (all-defined-out)
+         #%top-interaction
+         #%datum
+         (rename-out [basic-module-begin #%module-begin]))
+
+(define #'(basic-module-begin PARSE-TREE ...)
+  #'(#%module-begin
+     'PARSE-TREE ...))
+
+(define #'(basic-program LINE ...)
+  #'(begin
+      (define program-lines (vector LINE ...))
+      (run program-lines)))
+
+(define (run program-lines)
+  (for/fold ([line-idx 0])
+            ([i (in-naturals)]
+             #:break (= line-idx (vector-length program-lines)))
+    (match-define (list line-number proc jump-number)
+      (vector-ref program-lines line-idx))
+    (when proc (proc))
+    (if jump-number
+        (for/first ([idx (in-range (vector-length program-lines))]
+                    #:when (= (car (vector-ref program-lines idx)) jump-number))
+                   idx)
+        (add1 line-idx))))
+
+(define-cases #'line
+  [#'(line 'end) #'(list #f #f #f)]
+  [#'(_ NUMBER (statement ARG ...) 'end) #'(list NUMBER (statement ARG ...) #f)]
+  [#'(_ (statement ARG ...) 'end) #'(list #f (statement ARG ...) #f)])
+
+(define-cases #'statement
+  [#'(_ "PRINT" EXPR-LIST) #'(λ _ (begin (for-each display EXPR-LIST) (displayln "")))])
+
+(define-cases #'expr-list
+  [#'(_ EXPR ...) #'(list EXPR ...)])
+

beautiful-racket/br/basic/parser.rkt

@@ -0,0 +1,32 @@
+#lang ragg
+
+basic-program : line*
+
+line : CR | NUMBER statement CR | statement CR
+| NUMBER statement | statement
+
+statement : "PRINT" expr-list
+| "IF" expression relop expression "THEN" statement
+| "GOTO" expression
+| "INPUT" var-list
+| "LET" var "=" expression
+| "GOSUB" expression
+| "RETURN"
+| "CLEAR"
+| "LIST"
+| "RUN"
+| "END"
+
+expr-list : (STRING | expression) ("," (STRING | expression) )*
+
+var-list : var ("," var)*
+
+expression : term (("+"|"-") term)*
+
+term : factor (("*"|"/") factor)*
+
+factor : var | NUMBER | (expression)
+
+var : UPPERCASE
+
+relop : "<" (">"|"="|"ε") | ">" ("<"|"="|"ε") | "="

beautiful-racket/br/basic/reader.rkt

@@ -0,0 +1,7 @@
+#lang br
+(require br/reader-utils br/basic/parser br/basic/tokenizer)
+
+(define-read-and-read-syntax (source-path input-port)
+  (strip-context
+   #`(module bf-mod br/basic/expander
+       #,(parse source-path (tokenize input-port)))))

beautiful-racket/br/basic/test.rkt

@@ -0,0 +1,2 @@
+#lang br/basic
+20 GOTO 10

beautiful-racket/br/basic/tokenizer.rkt

@@ -0,0 +1,24 @@
+#lang br
+(require parser-tools/lex
+         (prefix-in : parser-tools/lex-sre)
+         ragg/support
+         racket/string)
+(provide tokenize)
+
+(define (tokenize input-port)
+  (define (next-token)
+    (define get-token
+      (lexer
+       ["\n" (token 'CR ''end)]
+       [(union "PRINT" "IF" "THEN" "GOTO"
+               "INPUT" "LET" "GOSUB" "RETURN"
+               "CLEAR" "LIST" "RUN" "END") lexeme]
+       ;; this only matches integers
+       [(repetition 1 +inf.0 numeric) (token 'NUMBER (string->number lexeme))]
+       [(char-set ",+-ε*/<>=") lexeme]
+       [upper-case (token 'UPPERCASE lexeme)]
+       [whitespace (token 'WHITESPACE lexeme #:skip? #t)]
+       [(:seq "\"" (complement (:: any-string "\"" any-string)) "\"") (token 'STRING (string-trim lexeme "\""))]
+       [(eof) eof]))
+    (get-token input-port))  
+  next-token)