set up basic-demo-2

8 years ago · c58ac2a806
parent d0f83eb24a
commit c58ac2a806
16 changed files with 352 additions and 0 deletions
--- a/beautiful-racket-demo/basic-demo-2/expander-runtime-errors.rkt
+++ b/beautiful-racket-demo/basic-demo-2/expander-runtime-errors.rkt
@ -0,0 +1,61 @@
+#lang br/quicklang
+(provide (rename-out [b-module-begin #%module-begin])
+         (matching-identifiers-out #rx"^b-" (all-defined-out)))
+
+(define-macro (b-module-begin (b-program LINE ...))
+  (with-pattern
+      ([(LINE-NUM ...)
+        (filter-stx-prop 'b-line-number
+                         (stx-flatten #'(LINE ...)))]
+       [(LINE-ID ...) (prefix-ids "line-" #'(LINE-NUM ...))])
+    #'(#%module-begin
+       LINE ...
+       (define line-table
+         (apply hasheqv (append (list LINE-NUM LINE-ID) ...)))
+       (run line-table))))
+
+(define-macro (b-line LINE-NUMBER STATEMENT ...)
+  (with-pattern
+      ([LINE-NUMBER-ID (prefix-id "line-" #'LINE-NUMBER
+                                  #:source #'LINE-NUMBER)]
+       [ORIG-LOC caller-stx])
+    (syntax/loc caller-stx
+      (define (LINE-NUMBER-ID #:srcloc? [loc #f])
+        (if loc
+            (syntax-srcloc #'ORIG-LOC)
+            (begin (void) STATEMENT ...))))))
+
+(define b-rem void)
+(define (b-print [val ""]) (displayln val))
+(define (b-sum . nums) (apply + nums))
+(define (b-num-expr expr)
+  (if (integer? expr) (inexact->exact expr) expr))
+
+(struct $program-end-signal ())
+(define (b-end) (raise ($program-end-signal)))
+
+(struct $change-line-signal (val))
+(define (b-goto expr) (raise ($change-line-signal expr)))
+
+(define-exn line-not-found exn:fail)
+
+(define (run line-table)
+  (define line-vec
+    (list->vector (sort (hash-keys line-table) <)))
+  (with-handlers ([$program-end-signal? void])
+    (for/fold ([line-idx 0])
+              ([i (in-naturals)])
+      (unless (< line-idx (vector-length line-vec)) (b-end))
+      (define line-num (vector-ref line-vec line-idx))
+      (define line-proc (hash-ref line-table line-num))
+      (with-handlers
+          ([$change-line-signal?
+            (λ (cls)
+              (define clsv ($change-line-signal-val cls))
+              (or
+               (and (exact-positive-integer? clsv)
+                    (vector-member clsv line-vec))
+               (raise-line-not-found
+                (line-proc #:srcloc? #t))))])
+        (line-proc)
+        (add1 line-idx)))))
--- a/beautiful-racket-demo/basic-demo-2/expander.rkt
+++ b/beautiful-racket-demo/basic-demo-2/expander.rkt
@ -0,0 +1,85 @@
+#lang br/quicklang
+(require (for-syntax racket/list sugar/debug))
+(provide (matching-identifiers-out #rx"^b-" (all-defined-out)))
+
+(struct line-error (msg))
+
+(define (handle-line-error num le)
+  (error (format "error in line ~a: ~a" num (line-error-msg le))))
+
+(define return-ks empty)
+
+(define (b-gosub num-expr)
+  (let/cc return-k
+    (push! return-ks return-k)
+    (b-goto num-expr)))
+
+(define (b-return)
+  (unless (pair? return-ks)
+    (raise (line-error "return without gosub")))
+  (define top-return-k (pop! return-ks))
+  (top-return-k))
+
+(define-macro (b-line NUM STATEMENT ...)
+  (with-pattern ([LINE-NUM (prefix-id "line-" #'NUM
+                                      #:source #'NUM)])
+    (syntax/loc caller-stx
+      (define (LINE-NUM)
+        (with-handlers ([line-error? (λ (le) (handle-line-error NUM le))])
+          (void) STATEMENT ...)))))
+
+(define-for-syntax (find-unique-var-names stx)
+  (remove-duplicates
+   (for/list ([var-stx (in-list (syntax-flatten stx))]
+              #:when (syntax-property var-stx 'b-id))
+             var-stx)
+   #:key syntax->datum))
+
+(define-macro (b-module-begin (b-program LINE ...))
+  (with-pattern
+      ([((b-line NUM STMT ...) ...) #'(LINE ...)]
+       [(LINE-FUNC ...) (prefix-id "line-" #'(NUM ...))]
+       [(VAR-NAME ...) (find-unique-var-names #'(LINE ...))])
+    #'(#%module-begin
+       (define VAR-NAME 0) ...
+       LINE ...
+       (define line-table
+         (apply hasheqv (append (list NUM LINE-FUNC) ...)))
+       (void (run line-table)))))
+(provide (rename-out [b-module-begin #%module-begin]))
+
+(define-macro (b-let ID VAL)
+  #'(set! ID VAL))
+
+(struct end-program-signal ())
+(struct change-line-signal (val))
+
+(define (b-end) (raise (end-program-signal)))
+(define (b-goto num-expr) (raise (change-line-signal num-expr)))
+
+(define (run line-table)
+  (define line-vec
+    (list->vector (sort (hash-keys line-table) <)))
+  (with-handlers ([end-program-signal? (λ (exn-val) (void))])
+    (for/fold ([line-idx 0])
+              ([i (in-naturals)]
+               #:break (>= line-idx (vector-length line-vec)))
+      (define line-num (vector-ref line-vec line-idx))
+      (define line-func (hash-ref line-table line-num))
+      (with-handlers
+          ([change-line-signal?
+            (λ (cls)
+              (define clsv (change-line-signal-val cls))
+              (or
+               (and (exact-positive-integer? clsv)
+                    (vector-member clsv line-vec))
+               (error (format "error in line ~a: line ~a not found"
+                              line-num clsv))))])
+        (line-func)
+        (add1 line-idx)))))
+
+(define (b-rem val) (void))
+(define (b-print [val ""]) (displayln val))
+(define (b-sum . nums) (apply + nums))
+(define (b-num-expr expr)
+  (if (integer? expr) (inexact->exact expr) expr))
--- a/beautiful-racket-demo/basic-demo-2/gosub.rkt
+++ b/beautiful-racket-demo/basic-demo-2/gosub.rkt
@ -0,0 +1,3 @@
+#lang br
+(provide b-gosub b-return)
+
--- a/beautiful-racket-demo/basic-demo-2/info.rkt
+++ b/beautiful-racket-demo/basic-demo-2/info.rkt
@ -0,0 +1,4 @@
+#lang info
+
+(define compile-omit-paths 'all)
+(define test-omit-paths 'all)
--- a/beautiful-racket-demo/basic-demo-2/lexer-test.rkt
+++ b/beautiful-racket-demo/basic-demo-2/lexer-test.rkt
@ -0,0 +1,58 @@
+#lang br
+(require "lexer.rkt" brag/support rackunit)
+
+(define (lex str)
+  (apply-lexer basic-lexer str))
+
+(check-equal? (lex "") empty)
+(check-equal?
+ (lex " ")
+ (list (srcloc-token (token " " #:skip? #t)
+                     (srcloc 'string #f #f 1 1))))
+(check-equal?
+ (lex "rem ignored\n")
+ (list (srcloc-token (token 'REM "rem ignored")
+                     (srcloc 'string #f #f 1 11))
+       (srcloc-token (token 'NEWLINE "\n")
+                     (srcloc 'string #f #f 12 1))))
+(check-equal?
+ (lex "print")
+ (list (srcloc-token "print"
+                     (srcloc 'string #f #f 1 5))))
+(check-equal?
+ (lex "goto")
+ (list (srcloc-token "goto"
+                     (srcloc 'string #f #f 1 4))))
+(check-equal?
+ (lex "end")
+ (list (srcloc-token "end"
+                     (srcloc 'string #f #f 1 3))))
+(check-equal?
+ (lex "+")
+ (list (srcloc-token "+"
+                     (srcloc 'string #f #f 1 1))))
+(check-equal?
+ (lex "12")
+ (list (srcloc-token (token 'INTEGER 12)
+                     (srcloc 'string #f #f 1 2))))
+(check-equal?
+ (lex "1.2")
+ (list (srcloc-token (token 'DECIMAL 1.2)
+                     (srcloc 'string #f #f 1 3))))
+(check-equal?
+ (lex "12.")
+ (list (srcloc-token (token 'DECIMAL 12.)
+                     (srcloc 'string #f #f 1 3))))
+(check-equal?
+ (lex ".12")
+ (list (srcloc-token (token 'DECIMAL .12)
+                     (srcloc 'string #f #f 1 3))))
+(check-equal?
+ (lex "\"foo\"")
+ (list (srcloc-token (token 'STRING "foo")
+                     (srcloc 'string #f #f 1 5))))
+(check-equal?
+ (lex "'foo'")
+ (list (srcloc-token (token 'STRING "foo")
+                     (srcloc 'string #f #f 1 5))))
+(check-exn exn:fail:read? (lambda () (lex "x")))
--- a/beautiful-racket-demo/basic-demo-2/lexer.rkt
+++ b/beautiful-racket-demo/basic-demo-2/lexer.rkt
@ -0,0 +1,23 @@
+#lang br
+(require brag/support)
+
+(define-lex-abbrev digits (:+ (char-set "0123456789")))
+
+(define basic-lexer
+  (lexer-srcloc
+   [(eof) (return-without-srcloc eof)]
+   ["\n" (token 'NEWLINE lexeme)]
+   [whitespace (token lexeme #:skip? #t)]
+   [(from/stop-before "rem" "\n") (token 'REM lexeme)]
+   [(:or "print" "goto" "end" "+" ":" "gosub" "return" "let" "=") lexeme]
+   [(:seq (:+ alphabetic) (:* (:or alphabetic numeric))) (token 'ID (string->symbol lexeme))]
+   [digits (token 'INTEGER (string->number lexeme))]
+   [(:or (:seq (:? digits) "." digits)
+         (:seq digits "."))
+    (token 'DECIMAL (string->number lexeme))]
+   [(:or (from/to "\"" "\"") (from/to "'" "'"))
+    (token 'STRING
+           (substring lexeme
+                      1 (sub1 (string-length lexeme))))]))
+
+(provide basic-lexer)
--- a/beautiful-racket-demo/basic-demo-2/main.rkt
+++ b/beautiful-racket-demo/basic-demo-2/main.rkt
@ -0,0 +1,11 @@
+#lang br/quicklang
+(require "parser.rkt" "tokenizer.rkt")
+
+(define (read-syntax path port)
+  (define parse-tree (parse path (make-tokenizer port path)))
+  (strip-bindings
+   #`(module basic-mod basic-demo-2/expander
+       #,parse-tree)))
+
+(module+ reader
+  (provide read-syntax))
--- a/beautiful-racket-demo/basic-demo-2/parse-only.rkt
+++ b/beautiful-racket-demo/basic-demo-2/parse-only.rkt
@ -0,0 +1,14 @@
+#lang br/quicklang
+(require "parser.rkt" "tokenizer.rkt")
+
+(define (read-syntax path port)
+  (define parse-tree (parse path (make-tokenizer port path)))
+  (strip-bindings
+   #`(module basic-parser-mod basic-demo/parse-only
+       #,parse-tree)))
+(module+ reader (provide read-syntax))
+
+(define-macro (parser-only-mb PARSE-TREE)
+  #'(#%module-begin
+     'PARSE-TREE))
+(provide (rename-out [parser-only-mb #%module-begin]))
--- a/beautiful-racket-demo/basic-demo-2/parse-stx.rkt
+++ b/beautiful-racket-demo/basic-demo-2/parse-stx.rkt
@ -0,0 +1,15 @@
+#lang br/quicklang
+(require "parser.rkt" "tokenizer.rkt")
+
+(define (read-syntax path port)
+  (define parse-tree (parse path (make-tokenizer port path)))
+  (strip-bindings
+   #`(module basic-parser-mod basic-demo/parse-stx
+       #'#,parse-tree)))
+(module+ reader (provide read-syntax))
+
+(define-macro (parser-only-mb PARSE-STX)
+  #'(#%module-begin
+     PARSE-STX))
+(provide (rename-out [parser-only-mb #%module-begin]))
+(provide syntax)
--- a/beautiful-racket-demo/basic-demo-2/parser.rkt
+++ b/beautiful-racket-demo/basic-demo-2/parser.rkt
@ -0,0 +1,17 @@
+#lang brag
+b-program : [b-line] (/NEWLINE [b-line])*
+b-line : b-line-number [b-statement] (/":" [b-statement])*
+@b-line-number : INTEGER
+@b-statement : b-rem | b-end | b-print | b-goto | b-gosub | b-return | b-let
+b-rem : REM
+b-end : /"end"
+b-print : /"print" [STRING | b-num-expr]
+b-goto : /"goto" b-num-expr
+b-gosub : /"gosub" b-num-expr
+b-return : /"return"
+b-let : [/"let"] b-id /"=" b-num-expr
+@b-id : ID
+b-num-expr : b-sum
+b-sum : b-value (/"+" b-value)*
+@b-value : b-id | b-number
+@b-number : INTEGER | DECIMAL
--- a/beautiful-racket-demo/basic-demo-2/private/sample-pseudocode.rkt
+++ b/beautiful-racket-demo/basic-demo-2/private/sample-pseudocode.rkt
@ -0,0 +1,8 @@
+(define (30) (rem print "'ignored'"))
+(define (35) (void))
+(define (50) (print "never gets here"))
+(define (40) (end))
+(define (60) (print "three") (print (+ 1.0 3)))
+(define (70) (goto (+ 11 18.5 0.5)))
+(define (10) (print "one"))
+(define (20) (print) (goto 60) (end))
--- a/beautiful-racket-demo/basic-demo-2/sample-gosub.rkt
+++ b/beautiful-racket-demo/basic-demo-2/sample-gosub.rkt
@ -0,0 +1,10 @@
+#lang basic-demo-2
+10 gosub 41
+20 print "world"
+30 gosub 100
+31 print "hi"
+35 end
+40 return
+41 print "hello" : return
+100 print "third"
+110 goto 40
--- a/beautiful-racket-demo/basic-demo-2/sample-var.rkt
+++ b/beautiful-racket-demo/basic-demo-2/sample-var.rkt
@ -0,0 +1,8 @@
+#lang basic-demo-2
+10 a = 1 : a = 5
+20 gosub 150
+30 a = 25
+40 gosub 150
+50 end
+150 print a + a + a
+160 return
--- a/beautiful-racket-demo/basic-demo-2/test-parser.rkt
+++ b/beautiful-racket-demo/basic-demo-2/test-parser.rkt
@ -0,0 +1,11 @@
+#lang br
+(require "tokenizer.rkt" "parser.rkt" brag/support)
+
+(define str #<<here
+10 rem print
+20 end
+
+here
+  )
+
+(parse-tree (apply-tokenizer-maker make-tokenizer str))
--- a/beautiful-racket-demo/basic-demo-2/tokenize-only.rkt
+++ b/beautiful-racket-demo/basic-demo-2/tokenize-only.rkt
@ -0,0 +1,14 @@
+#lang br/quicklang
+(require brag/support "tokenizer.rkt")
+
+(define (read-syntax path port)
+  (define tokens (apply-tokenizer make-tokenizer port))
+  (strip-bindings
+   #`(module basic-tokens-mod basic-demo/tokenize-only
+       #,@tokens)))
+(module+ reader (provide read-syntax))
+
+(define-macro (parser-only-mb TOKEN ...)
+  #'(#%module-begin
+     (list TOKEN ...)))
+(provide (rename-out [parser-only-mb #%module-begin]))
--- a/beautiful-racket-demo/basic-demo-2/tokenizer.rkt
+++ b/beautiful-racket-demo/basic-demo-2/tokenizer.rkt
@ -0,0 +1,10 @@
+#lang br
+(require "lexer.rkt" brag/support)
+
+(define (make-tokenizer ip [path #f])
+  (port-count-lines! ip)
+  (lexer-file-path path)
+  (define (next-token) (basic-lexer ip))
+  next-token)
+
+(provide make-tokenizer)