boom

beautiful-racket-demo/basic-demo-nth/basic-test.rkt

@@ -0,0 +1,4 @@
+#lang basic-demo
+10 rem 20
+20 x = 42
+25 print x

beautiful-racket-demo/basic-demo-nth/colorer.rkt

@@ -0,0 +1,51 @@
+#lang br
+(require brag/support syntax-color/racket-lexer racket/contract
+         basic-demo/tokenizer sugar/coerce)
+
+(define (color-basic ip)
+  (define postok (basic-lexer ip))
+  (define tok (position-token-token postok))
+  (define-values (type val)
+    (cond
+      [(eof-object? tok) (values eof eof)]
+      [(string? tok) (values 'string tok)]
+      [else (values (token-struct-type tok)
+                    (format "~a" (token-struct-val tok)))]))
+  (values val
+          (caseq type
+                 [(WHITE) 'white-space]
+                 [(COMMENT) 'comment]
+                 [(NUMBER) 'constant]
+                 [(STRING) 'string]
+                 [else 'keyword])
+          #f
+          (position-offset (position-token-start-pos postok))
+          (position-offset (position-token-end-pos postok))))
+  
+
+#;(provide
+   (contract-out
+    [color-basic
+     (input-port? . -> . (values
+                          (or/c string? eof-object?)
+                          symbol?
+                          (or/c symbol? #f)
+                          (or/c exact-positive-integer? #f)
+                          (or/c exact-positive-integer? #f)))]))
+
+(define (apply-colorer colorer-proc str)
+  (let loop ([p (open-input-string str)][color-recs empty])
+    (define color-rec (values->list (colorer-proc p)))
+    (if (eof-object? (car color-rec))
+        (reverse color-recs)
+        (loop p (cons color-rec color-recs)))))
+
+(module+ main
+  (define str #<<HERE
+10 rem 20
+20 x = 42
+30 print x
+HERE
+    )
+
+  (apply-colorer color-basic str))

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

@@ -0,0 +1,260 @@
+#lang br/quicklang
+(require (for-syntax syntax/strip-context))
+(provide #%top-interaction #%app #%datum
+         (rename-out [basic-module-begin #%module-begin])
+         (all-defined-out))
+
+; BASIC implementation details
+; http://www.atariarchives.org/basicgames/showpage.php?page=i12
+
+(begin-for-syntax
+  (require racket/list)
+  (define (gather-unique-ids stx)
+    (remove-duplicates (map syntax->datum (filter (λ(s) (syntax-property s 'id)) (syntax-flatten stx))) eq?)))
+
+(define-macro (basic-module-begin (basic-program PROGRAM-LINE ...))
+  (with-pattern ([(UNIQUE-ID ...)
+                  (map (compose1 syntax-local-introduce (λ(id) (datum->syntax #f id)))
+                       (gather-unique-ids #'(PROGRAM-LINE ...)))])
+    #'(#%module-begin
+       (define UNIQUE-ID 0) ...
+       (provide UNIQUE-ID ...)
+       (run (sort (cons (line +inf.0 (statement "end"))
+                        (list PROGRAM-LINE ...)) #:key $line-number <)))))
+
+
+(struct exn:line-not-found 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 end-program-signal exn:fail ())
+(define (raise-end-program-signal)
+  (raise (end-program-signal "" (current-continuation-marks))))
+
+(struct end-line-signal exn:fail ())
+(define (raise-end-line-signal)
+  (raise (end-line-signal "" (current-continuation-marks))))
+
+(define (run line-list)
+  (define lines (list->vector line-list))
+  (define (find-index ln)
+    (or
+     (for/or ([idx (in-range (vector-length lines))])
+       (and (= ($line-number (vector-ref lines idx)) ln)
+            idx))
+     (raise-line-not-found-error ln)))
+  (void
+   (with-handlers ([end-program-signal? void])
+     (for/fold ([program-counter 0])
+               ([i (in-naturals)])
+       (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 current-return-stack (make-parameter empty))
+
+(define (basic:gosub where)
+  (let/cc return-k
+    (current-return-stack (cons return-k (current-return-stack)))
+    (basic:goto where)))
+
+(define current-line (make-parameter #f))
+(struct $line (number thunk) #:transparent)
+(define-macro (line NUMBER . STATEMENTS)
+  #'($line NUMBER (λ ()
+                    (current-line NUMBER)
+                    (with-handlers ([end-line-signal? (λ _ #f)]
+                                    [end-program-signal? raise]
+                                    [exn:fail? (λ(exn)
+                                                 (displayln (format "in line ~a" NUMBER))
+                                                 (raise exn))])
+                      . STATEMENTS))))
+
+(define-macro-cases statement
+  [(statement ID "=" EXPR) #'(basic:let ID EXPR)]
+  [(statement PROC-NAME . ARGS)
+   (with-pattern
+       ([PROC-ID (prefix-id "basic:" #'PROC-NAME)])
+     #'(PROC-ID . ARGS))])
+
+(define-macro-cases basic:let
+  [(_ (id-expr ID) EXPR)
+   #'(set! ID EXPR)]
+  [(_ (id-expr ID DIM-IDX ...) EXPR)
+   #'(array-set! ID DIM-IDX ... EXPR)])
+
+(define-macro-cases basic:if
+  [(_ COND-EXPR TRUE-EXPR FALSE-EXPR)
+   #'(if (true? COND-EXPR)
+         TRUE-EXPR
+         FALSE-EXPR)]
+  [(_ COND-EXPR TRUE-EXPR)
+   #'(if (true? COND-EXPR)
+         TRUE-EXPR
+         (raise-end-line-signal))]) ; special short-circuit rule for one-armed conditional
+
+(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-macro-cases id-expr
+  [(_ ID) #'(cond
+              [(procedure? ID) (ID)]
+              [(array? ID) (array-ref ID (make-vector (array-rank ID) 0))] ; no subscript => zeroth element
+              [else ID])]
+  [(_ ID EXPR0 EXPR ...) #'(cond
+                             [(procedure? ID) (ID EXPR0 EXPR ...)]
+                             [(array? ID) (array-ref ID EXPR0 EXPR ...)]
+                             [else (error 'id-expr-confused)])])
+
+(define-macro-cases expr
+  [(_ COMP-EXPR) #'COMP-EXPR]
+  [(_ COMP-EXPR "and" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)]
+  [(_ COMP-EXPR "or" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)])
+
+(define-macro-cases comp-expr
+  [(_ 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-cases sum
+  [(_ SUM) #'SUM]
+  [(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)]
+  [(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)])
+
+(define-macro-cases product
+  [(_ "-" VALUE) #'(- VALUE)]
+  [(_ VALUE) #'VALUE]
+  [(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)]
+  [(_ PRODUCT "/" VALUE) #'(/ PRODUCT VALUE)])
+
+(define-macro-cases power
+  [(_ BASE) #'BASE]
+  [(_ BASE POWER) #'(expt BASE POWER)])
+
+(define-macro-cases maybe-negative-val
+  [(_ "-" ID) #'(- ID)]
+  [(_ ID) #'ID])
+
+(define print-list list)
+
+(define (basic:print [args #f])
+  (define (println [x ""])
+    (define xstr (format "~a" x))
+    (displayln xstr)
+    (current-print-position 0))
+  (define (print x)
+    (define xstr (format "~a" x))
+    (display xstr)
+    (current-print-position (+ (current-print-position) (string-length xstr))))
+  
+  (match args
+    [#f (println)]
+    [(list print-list-items ... ";" pl)
+     (begin
+       (for-each
+        (λ(pli)
+          (print (if (number? pli)
+                     (format "~a " pli)
+                     pli)))
+        print-list-items)
+       (basic:print pl))]
+    [(list print-list-items ... ";") (for-each print print-list-items)]
+    [(list print-list-items ...)
+     (for-each println print-list-items)]))
+
+(define current-print-position (make-parameter 0))
+(define (TAB num) (make-string (max 0 (INT (- num (current-print-position)))) #\space))
+(define (INT num) (inexact->exact (truncate num)))
+(define (SIN num) (sin num))
+(define (ABS num) (inexact->exact (abs num)))
+(define (RND num) (* (random) num))
+(define (EXP num) (exp num))
+(define (SQR num) (sqrt num))
+
+(define-macro-cases basic:input
+  [(_ (print-list . PL-ITEMS) ID ...)
+   #'(begin
+       (basic:print (append (print-list . PL-ITEMS) (list ";")))
+       (basic:input ID) ...)]
+  [(_ ID ...) #'(begin
+                  (set! ID (let* ([str (read-line)]
+                                  [num (string->number (string-trim str))])
+                             (or num str))) ...)])
+
+(define (basic:goto where) where)
+
+(define-macro-cases basic:on
+  [(_ TEST-EXPR "goto" OPTION ...)
+   #'(basic:goto (list-ref (list OPTION ...) (sub1 TEST-EXPR)))]
+  [(_ TEST-EXPR "gosub" OPTION ...)
+   #'(basic:gosub (list-ref (list OPTION ...) (sub1 TEST-EXPR)))])
+
+
+(define (basic:return)
+  (define return-k (car (current-return-stack)))
+  (current-return-stack (cdr (current-return-stack)))
+  (return-k #f))
+
+(define (basic:stop) (basic:end))
+(define (basic:end) (raise-end-program-signal))
+
+(require srfi/25)
+
+(define-macro (basic:dim (id-expr ID EXPR ...) ...)
+  #'(begin
+      (set! ID (make-array (apply shape (append (list 0 (add1 EXPR)) ...)))) ...))
+
+(define current-for-stack (make-parameter empty))
+
+(define (push-for-stack thunk)
+  (current-for-stack (cons thunk (current-for-stack))))
+
+(define (pop-for-stack)
+  (current-for-stack (cdr (current-for-stack))))
+
+(define (in-closed-interval? x left right)
+  (define cmp (if (< left right) <= >=))
+  (cmp left x right))
+
+(define-macro-cases basic:for
+  [(_ VAR START-VALUE END-VALUE)
+   #'(basic:for VAR START-VALUE END-VALUE 1)]
+  [(_ VAR START-VALUE END-VALUE STEP-VALUE)
+   #'(begin
+       (statement (id-expr VAR) "=" START-VALUE) ; initialize the loop counter
+       (let/cc return-k ; create a return point
+         (push-for-stack (cons 'VAR
+                               (λ () ; thunk that increments counter & teleports back to beginning of loop
+                                 (define next-val (+ VAR STEP-VALUE))
+                                 (if (next-val . in-closed-interval? . START-VALUE END-VALUE)
+                                     (begin
+                                       (set! VAR next-val)
+                                       (return-k #f)) ; return value for subsequent visits to line
+                                     (pop-for-stack)))))
+         #f))]) ; return value for first visit to line
+
+(define (handle-next [which #f])
+  (unless (pair? (current-for-stack)) (error 'next "for-stack is empty"))
+  (define for-thunk (cdr (if which
+                             (assq which (current-for-stack))
+                             (car (current-for-stack)))))
+  (for-thunk))
+
+(define-macro (basic:next VAR ...)
+  #'(handle-next 'VAR ...))
+
+(define-macro (basic:def DEF-ID LAMBDA-ID EXPR)
+  #'(set! DEF-ID (λ (LAMBDA-ID) EXPR)))

beautiful-racket-demo/basic-demo-nth/main.rkt

@@ -0,0 +1,26 @@
+#lang br/quicklang
+(require "parser.rkt" "tokenizer.rkt")
+
+(module+ reader (provide read-syntax get-info))
+
+(define (read-syntax path port)
+  (define-values (line col pos) (port-next-location port))
+  (define port+newline (input-port-append #f port (open-input-string "\n")))
+  (port-count-lines! port+newline)
+  (set-port-next-location! port+newline line col pos)
+  (define parse-tree (parse path (tokenize port+newline)))
+  (strip-bindings
+   #`(module basic-mod basic-demo/expander
+       #,parse-tree)))
+
+(define (get-info port mod line col pos)
+    (define (handle-query key default)
+      (case key
+        #;[(color-lexer)
+         (dynamic-require 'basic-demo/colorer 'color-basic (λ () #f))]
+        #;[(drracket:indentation)
+         (dynamic-require 'basic-demo/indenter 'indent-jsonic (λ () #f))]
+        #;[(drracket:toolbar-buttons)
+         (dynamic-require 'basic-demo/buttons 'button-list (λ () #f))]
+        [else default]))
+    handle-query)

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

@@ -0,0 +1,42 @@
+#lang brag
+
+basic-program : line*
+
+line: NUMBER statement [/":" statement]*
+
+statement : "def" id /"(" id /")" /"=" expr
+| "dim" id-expr [/"," id-expr]*
+| "end" | "stop"
+| "gosub" expr
+| "goto" expr
+| "on" expr ("gosub" | "goto") expr [/"," expr]*
+| "if" expr /"then" (statement | expr) [/"else" (statement | expr)]
+| "input" [print-list /";"] id [/"," id]*
+| [/"let"] id-expr "=" expr
+| "print" [print-list]
+| "return"
+| "for" id /"=" expr /"to" expr [/"step" expr]
+| "next" [id]
+
+print-list : expr [[";"] [print-list]]
+
+expr : comp-expr [("and" | "or") expr]
+
+comp-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") comp-expr]
+
+sum : [sum ("+" | "-")] product
+
+product : [product ("*" | "/")] power
+
+power : value [/"^" value]
+
+@value : maybe-negative-val
+| id-expr
+| /"(" expr /")"
+| STRING
+
+id-expr : id [/"(" expr [/"," expr]* /")"]
+
+@id : ID
+
+maybe-negative-val : ["-"] (id-expr | NUMBER)

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

@@ -0,0 +1,68 @@
+#lang br
+(require parser-tools/lex
+         (prefix-in : parser-tools/lex-sre)
+         brag/support)
+(provide tokenize basic-lexer)
+
+(define-lex-abbrevs
+  (integer (:+ numeric))
+  ;; don't lex the leading "-": muddles "-X" and "Y-X"
+  (decimal (:or integer (:seq (:? integer) (:seq "." integer)))))
+
+
+(define basic-lexer
+  (lexer-src-pos
+   [(eof) eof]
+   [whitespace (token 'WHITE lexeme #:skip? #t
+                      #:position (pos lexeme-start)
+                      #:line (line lexeme-start)
+                      #:column (col lexeme-start)
+                      #:span (- (pos lexeme-end)
+                                (pos lexeme-start)))]
+   [(:or (from/to "/*" "*/")
+         (:: decimal (:+ whitespace) (from/to (uc+lc "rem") "\n")))
+    (token 'COMMENT lexeme #:skip? #t
+           #:position (pos lexeme-start)
+           #:line (line lexeme-start)
+           #:column (col lexeme-start)
+           #:span (- (pos lexeme-end)
+                     (pos lexeme-start)))]
+   [(:or (uc+lc "print" "for" "to" "step" "if"
+                "goto" "input" "let" "next"
+                "return" "clear" "list" "run"
+                "end" "then" "else" "gosub"
+                "and" "or" "stop" "let" "def" "dim" "on")
+         ";" "=" "(" ")" "+" "-" "*" "/" "^"
+         "<=" ">=" "<>" "<" ">" "=" ":" ",") (token (string-downcase lexeme)
+                                                    (string-downcase lexeme)
+                                                    #:position (pos lexeme-start)
+                                                    #:line (line lexeme-start)
+                                                    #:column (col lexeme-start)
+                                                    #:span (- (pos lexeme-end)
+                                                              (pos lexeme-start)))]
+   [decimal (token 'NUMBER (string->number lexeme)
+                   #:position (pos lexeme-start)
+                   #:line (line lexeme-start)
+                   #:column (col lexeme-start)
+                   #:span (- (pos lexeme-end)
+                             (pos lexeme-start)))]
+   [(:: alphabetic (:* (:or alphabetic numeric)) (:? "$")) (token 'ID (string->symbol lexeme)
+                                                                  #:position (pos lexeme-start)
+                                                                  #:line (line lexeme-start)
+                                                                  #:column (col lexeme-start)
+                                                                  #:span (- (pos lexeme-end)
+                                                                            (pos lexeme-start)))]
+   [(from/to "\"" "\"") (token 'STRING (trim-ends  "\"" lexeme  "\"")
+                               #:position (+ (pos lexeme-start) 1)
+                               #:line (line lexeme-start)
+                               #:column (+ (col lexeme-start) 1)
+                               #:span (- (pos lexeme-end)
+                                         (pos lexeme-start) 2))]))
+
+(define (tokenize ip)
+  (port-count-lines! ip)
+  (define (next-token) (basic-lexer ip))  
+  next-token)
+
+(module+ main
+  (apply-tokenizer tokenize "\n10 rem foo\n15 print x\n20 rem\n"))

beautiful-racket-demo/basic-demo/basic-test.rkt

@@ -0,0 +1,7 @@
+#lang basic-demo
+10 rem what?
+20 print "hello"
+30 rem goto 50
+45 print "shite"
+50 print "foobar"
+30 goto 50

beautiful-racket-demo/basic-demo/colorer.rkt

@@ -3,11 +3,11 @@
          basic-demo/tokenizer sugar/coerce)
 
 (define (color-basic ip)
-  (define postok ((tokenize ip)))
+  (define postok (basic-lexer ip))
   (define tok (position-token-token postok))
   (define-values (type val)
     (cond
-      [(eof-object? tok) (values 'eof "")]
+      [(eof-object? tok) (values eof eof)]
       [(string? tok) (values 'string tok)]
       [else (values (token-struct-type tok)
                     (format "~a" (token-struct-val tok)))]))
@@ -17,30 +17,35 @@
                  [(COMMENT) 'comment]
                  [(NUMBER) 'constant]
                  [(STRING) 'string]
-                 [else 'no-color])
+                 [else 'keyword])
           #f
           (position-offset (position-token-start-pos postok))
           (position-offset (position-token-end-pos postok))))
   
 
-(provide
- (contract-out
-  [color-basic
-   (input-port? . -> . (values
-                        (or/c string? eof-object?)
-                        symbol?
-                        (or/c symbol? #f)
-                        (or/c exact-positive-integer? #f)
-                        (or/c exact-positive-integer? #f)))]))
+#;(provide
+   (contract-out
+    [color-basic
+     (input-port? . -> . (values
+                          (or/c string? eof-object?)
+                          symbol?
+                          (or/c symbol? #f)
+                          (or/c exact-positive-integer? #f)
+                          (or/c exact-positive-integer? #f)))]))
 
-(module+ main
-  (define p (open-input-string #<<HERE
+(define (apply-colorer colorer-proc str)
+  (let loop ([p (open-input-string str)][color-recs empty])
+    (define color-rec (values->list (colorer-proc p)))
+    (if (eof-object? (car color-rec))
+        (reverse color-recs)
+        (loop p (cons color-rec color-recs)))))
 
-10 rem foo
-20 rem foo
-30 let x = 42
+(module+ main
+  (define str #<<HERE
+10 rem 20
+20 x = 42
+30 print x
 HERE
-                               ))
-  (color-basic p)
-  (color-basic p)
-  (color-basic p))
+    )
+
+  (apply-colorer color-basic str))

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

@@ -1,260 +1,47 @@
 #lang br/quicklang
-(require (for-syntax syntax/strip-context))
-(provide #%top-interaction #%app #%datum
-         (rename-out [basic-module-begin #%module-begin])
+(provide (rename-out [b-module-begin #%module-begin])
          (all-defined-out))
 
-; BASIC implementation details
-; http://www.atariarchives.org/basicgames/showpage.php?page=i12
-
-(begin-for-syntax
-  (require racket/list)
-  (define (gather-unique-ids stx)
-    (remove-duplicates (map syntax->datum (filter (λ(s) (syntax-property s 'id)) (syntax-flatten stx))) eq?)))
-
-(define-macro (basic-module-begin (basic-program PROGRAM-LINE ...))
-  (with-pattern ([(UNIQUE-ID ...)
-                  (map (compose1 syntax-local-introduce (λ(id) (datum->syntax #f id)))
-                       (gather-unique-ids #'(PROGRAM-LINE ...)))])
-    #'(#%module-begin
-       (define UNIQUE-ID 0) ...
-       (provide UNIQUE-ID ...)
-       (run (sort (cons (line +inf.0 (statement "end"))
-                        (list PROGRAM-LINE ...)) #:key $line-number <)))))
-
-
-(struct exn:line-not-found 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 end-program-signal exn:fail ())
-(define (raise-end-program-signal)
-  (raise (end-program-signal "" (current-continuation-marks))))
-
-(struct end-line-signal exn:fail ())
-(define (raise-end-line-signal)
-  (raise (end-line-signal "" (current-continuation-marks))))
-
-(define (run line-list)
-  (define lines (list->vector line-list))
-  (define (find-index ln)
-    (or
-     (for/or ([idx (in-range (vector-length lines))])
-       (and (= ($line-number (vector-ref lines idx)) ln)
-            idx))
-     (raise-line-not-found-error ln)))
-  (void
-   (with-handlers ([end-program-signal? void])
-     (for/fold ([program-counter 0])
-               ([i (in-naturals)])
-       (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 current-return-stack (make-parameter empty))
-
-(define (basic:gosub where)
-  (let/cc return-k
-    (current-return-stack (cons return-k (current-return-stack)))
-    (basic:goto where)))
-
-(define current-line (make-parameter #f))
-(struct $line (number thunk) #:transparent)
-(define-macro (line NUMBER . STATEMENTS)
-  #'($line NUMBER (λ ()
-                    (current-line NUMBER)
-                    (with-handlers ([end-line-signal? (λ _ #f)]
-                                    [end-program-signal? raise]
-                                    [exn:fail? (λ(exn)
-                                                 (displayln (format "in line ~a" NUMBER))
-                                                 (raise exn))])
-                      . STATEMENTS))))
-
-(define-macro-cases statement
-  [(statement ID "=" EXPR) #'(basic:let ID EXPR)]
-  [(statement PROC-NAME . ARGS)
-   (with-pattern
-       ([PROC-ID (prefix-id "basic:" #'PROC-NAME)])
-     #'(PROC-ID . ARGS))])
-
-(define-macro-cases basic:let
-  [(_ (id-expr ID) EXPR)
-   #'(set! ID EXPR)]
-  [(_ (id-expr ID DIM-IDX ...) EXPR)
-   #'(array-set! ID DIM-IDX ... EXPR)])
-
-(define-macro-cases basic:if
-  [(_ COND-EXPR TRUE-EXPR FALSE-EXPR)
-   #'(if (true? COND-EXPR)
-         TRUE-EXPR
-         FALSE-EXPR)]
-  [(_ COND-EXPR TRUE-EXPR)
-   #'(if (true? COND-EXPR)
-         TRUE-EXPR
-         (raise-end-line-signal))]) ; special short-circuit rule for one-armed conditional
-
-(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-macro-cases id-expr
-  [(_ ID) #'(cond
-              [(procedure? ID) (ID)]
-              [(array? ID) (array-ref ID (make-vector (array-rank ID) 0))] ; no subscript => zeroth element
-              [else ID])]
-  [(_ ID EXPR0 EXPR ...) #'(cond
-                             [(procedure? ID) (ID EXPR0 EXPR ...)]
-                             [(array? ID) (array-ref ID EXPR0 EXPR ...)]
-                             [else (error 'id-expr-confused)])])
-
-(define-macro-cases expr
-  [(_ COMP-EXPR) #'COMP-EXPR]
-  [(_ COMP-EXPR "and" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)]
-  [(_ COMP-EXPR "or" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)])
-
-(define-macro-cases comp-expr
-  [(_ 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-cases sum
-  [(_ SUM) #'SUM]
-  [(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)]
-  [(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)])
-
-(define-macro-cases product
-  [(_ "-" VALUE) #'(- VALUE)]
-  [(_ VALUE) #'VALUE]
-  [(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)]
-  [(_ PRODUCT "/" VALUE) #'(/ PRODUCT VALUE)])
-
-(define-macro-cases power
-  [(_ BASE) #'BASE]
-  [(_ BASE POWER) #'(expt BASE POWER)])
-
-(define-macro-cases maybe-negative-val
-  [(_ "-" ID) #'(- ID)]
-  [(_ ID) #'ID])
-
-(define print-list list)
-
-(define (basic:print [args #f])
-  (define (println [x ""])
-    (define xstr (format "~a" x))
-    (displayln xstr)
-    (current-print-position 0))
-  (define (print x)
-    (define xstr (format "~a" x))
-    (display xstr)
-    (current-print-position (+ (current-print-position) (string-length xstr))))
-  
-  (match args
-    [#f (println)]
-    [(list print-list-items ... ";" pl)
-     (begin
-       (for-each
-        (λ(pli)
-          (print (if (number? pli)
-                     (format "~a " pli)
-                     pli)))
-        print-list-items)
-       (basic:print pl))]
-    [(list print-list-items ... ";") (for-each print print-list-items)]
-    [(list print-list-items ...)
-     (for-each println print-list-items)]))
-
-(define current-print-position (make-parameter 0))
-(define (TAB num) (make-string (max 0 (INT (- num (current-print-position)))) #\space))
-(define (INT num) (inexact->exact (truncate num)))
-(define (SIN num) (sin num))
-(define (ABS num) (inexact->exact (abs num)))
-(define (RND num) (* (random) num))
-(define (EXP num) (exp num))
-(define (SQR num) (sqrt num))
-
-(define-macro-cases basic:input
-  [(_ (print-list . PL-ITEMS) ID ...)
-   #'(begin
-       (basic:print (append (print-list . PL-ITEMS) (list ";")))
-       (basic:input ID) ...)]
-  [(_ ID ...) #'(begin
-                  (set! ID (let* ([str (read-line)]
-                                  [num (string->number (string-trim str))])
-                             (or num str))) ...)])
-
-(define (basic:goto where) where)
-
-(define-macro-cases basic:on
-  [(_ TEST-EXPR "goto" OPTION ...)
-   #'(basic:goto (list-ref (list OPTION ...) (sub1 TEST-EXPR)))]
-  [(_ TEST-EXPR "gosub" OPTION ...)
-   #'(basic:gosub (list-ref (list OPTION ...) (sub1 TEST-EXPR)))])
-
-
-(define (basic:return)
-  (define return-k (car (current-return-stack)))
-  (current-return-stack (cdr (current-return-stack)))
-  (return-k #f))
-
-(define (basic:stop) (basic:end))
-(define (basic:end) (raise-end-program-signal))
-
-(require srfi/25)
-
-(define-macro (basic:dim (id-expr ID EXPR ...) ...)
-  #'(begin
-      (set! ID (make-array (apply shape (append (list 0 (add1 EXPR)) ...)))) ...))
-
-(define current-for-stack (make-parameter empty))
-
-(define (push-for-stack thunk)
-  (current-for-stack (cons thunk (current-for-stack))))
-
-(define (pop-for-stack)
-  (current-for-stack (cdr (current-for-stack))))
-
-(define (in-closed-interval? x left right)
-  (define cmp (if (< left right) <= >=))
-  (cmp left x right))
-
-(define-macro-cases basic:for
-  [(_ VAR START-VALUE END-VALUE)
-   #'(basic:for VAR START-VALUE END-VALUE 1)]
-  [(_ VAR START-VALUE END-VALUE STEP-VALUE)
-   #'(begin
-       (statement (id-expr VAR) "=" START-VALUE) ; initialize the loop counter
-       (let/cc return-k ; create a return point
-         (push-for-stack (cons 'VAR
-                               (λ () ; thunk that increments counter & teleports back to beginning of loop
-                                 (define next-val (+ VAR STEP-VALUE))
-                                 (if (next-val . in-closed-interval? . START-VALUE END-VALUE)
-                                     (begin
-                                       (set! VAR next-val)
-                                       (return-k #f)) ; return value for subsequent visits to line
-                                     (pop-for-stack)))))
-         #f))]) ; return value for first visit to line
-
-(define (handle-next [which #f])
-  (unless (pair? (current-for-stack)) (error 'next "for-stack is empty"))
-  (define for-thunk (cdr (if which
-                             (assq which (current-for-stack))
-                             (car (current-for-stack)))))
-  (for-thunk))
-
-(define-macro (basic:next VAR ...)
-  #'(handle-next 'VAR ...))
-
-(define-macro (basic:def DEF-ID LAMBDA-ID EXPR)
-  #'(set! DEF-ID (λ (LAMBDA-ID) EXPR)))
+(define-exn-srcloc duplicate-line-number exn:fail)
+
+(define-macro (b-module-begin (b-program LINE ...))
+  #'(#%module-begin
+     (define lines (sort (list LINE ...) #:key $line-number <))
+     (unless (apply < (map $line-number lines))
+       (raise-duplicate-line-number
+        ($line-srcloc (check-duplicates lines = #:key $line-number))))
+     (run lines)))
+
+(struct $line (number thunk srcloc) #:transparent)
+
+(define-macro (b-line LINE-NUMBER STATEMENT)
+  (with-pattern ([SRCLOC (syntax-srcloc caller-stx)])
+    #'($line LINE-NUMBER (thunk STATEMENT) SRCLOC)))
+
+(define-macro (b-statement (PROC-NAME ARG ...))
+  #'(begin (PROC-NAME ARG ...)))
+
+(define (b-rem str) #f)
+(define (b-print str) (displayln str))
+(define (b-goto line-number) line-number)
+
+(define-exn end-program-signal exn:fail)
+(define (b-end) (raise-end-program-signal))
+
+(define-exn-srcloc line-not-found exn:fail)
+
+(define (run lines)
+  (define line-vec (list->vector lines))
+  (define line-idx-table (for/hasheqv ([(line idx) (in-indexed line-vec)])
+                           (values ($line-number line) idx)))
+  (with-handlers ([end-program-signal? void])
+    (for/fold ([line-idx 0])
+              ([i (in-naturals)])
+      (unless (< line-idx (vector-length line-vec)) (b-end))
+      (define this-line (vector-ref line-vec line-idx))
+      (define this-thunk ($line-thunk this-line))
+      (define this-result (this-thunk))
+      (if (exact-positive-integer? this-result)
+          (hash-ref line-idx-table this-result
+                    (thunk (raise-line-not-found ($line-srcloc this-line))))
+          (add1 line-idx)))))

beautiful-racket-demo/basic-demo/importer.rkt

@@ -0,0 +1,2 @@
+#lang br
+(require "basic-test.rkt")

beautiful-racket-demo/basic-demo/main.rkt

@@ -1,7 +1,7 @@
 #lang br/quicklang
 (require "parser.rkt" "tokenizer.rkt")
 
-(module+ reader (provide read-syntax get-info))
+(module+ reader (provide read-syntax))
 
 (define (read-syntax path port)
   (define-values (line col pos) (port-next-location port))
@@ -12,15 +12,3 @@
   (strip-bindings
    #`(module basic-mod basic-demo/expander
        #,parse-tree)))
-
-(define (get-info port mod line col pos)
-    (define (handle-query key default)
-      (case key
-        [(color-lexer)
-         (dynamic-require 'basic-demo/colorer 'color-basic)]
-        #;[(drracket:indentation)
-         (dynamic-require 'basic-demo/indenter 'indent-jsonic)]
-        #;[(drracket:toolbar-buttons)
-         (dynamic-require 'basic-demo/buttons 'button-list)]
-        [else default]))
-    handle-query)

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

@@ -1,42 +1,18 @@
 #lang brag
 
-basic-program : line*
+b-program : b-line*
 
-line: NUMBER statement [/":" statement]*
+b-line: NUMBER b-statement
 
-statement : "def" id /"(" id /")" /"=" expr
-| "dim" id-expr [/"," id-expr]*
-| "end" | "stop"
-| "gosub" expr
-| "goto" expr
-| "on" expr ("gosub" | "goto") expr [/"," expr]*
-| "if" expr /"then" (statement | expr) [/"else" (statement | expr)]
-| "input" [print-list /";"] id [/"," id]*
-| [/"let"] id-expr "=" expr
-| "print" [print-list]
-| "return"
-| "for" id /"=" expr /"to" expr [/"step" expr]
-| "next" [id]
+b-statement: b-rem
+| b-print
+| b-goto
+| b-end
 
-print-list : expr [[";"] [print-list]]
+b-rem : REM
 
-expr : comp-expr [("and" | "or") expr]
+b-print : /"print" STRING
 
-comp-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") comp-expr]
+b-goto : /"goto" NUMBER
 
-sum : [sum ("+" | "-")] product
-
-product : [product ("*" | "/")] power
-
-power : value [/"^" value]
-
-@value : maybe-negative-val
-| id-expr
-| /"(" expr /")"
-| STRING
-
-id-expr : id [/"(" expr [/"," expr]* /")"]
-
-@id : ID
-
-maybe-negative-val : ["-"] (id-expr | NUMBER)
+b-end : /"end"

beautiful-racket-demo/basic-demo/runtime.rkt

@@ -0,0 +1,3 @@
+#lang br
+(provide (all-defined-out))
+(define current-print-status (make-parameter #t))

beautiful-racket-demo/basic-demo/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 tokenize str))

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

@@ -1,46 +1,46 @@
 #lang br
-(require parser-tools/lex (prefix-in : parser-tools/lex-sre)
-         brag/support racket/string)
-(provide tokenize)
+(require parser-tools/lex
+         (prefix-in : parser-tools/lex-sre)
+         brag/support)
+(provide (all-defined-out))
 
-(define-lex-abbrevs
-  (positive-integer (:+ numeric))
-  ;; don't lex the leading "-": muddles "-X" and "Y-X"
-  (positive-number (:or positive-integer (:seq (:? positive-integer) (:seq "." positive-integer)))))
+(define basic-lexer
+  (lexer-src-pos
+   [(eof) eof]
+   [whitespace (token lexeme #:skip? #t)]
+   [(from/to "rem" "\n")
+    (token 'REM
+           (string-downcase lexeme)
+           #:position (pos lexeme-start)
+           #:line (line lexeme-start)
+           #:column (col lexeme-start)
+           #:span (- (pos lexeme-end)
+                     (pos lexeme-start)))]
+   [(:or "print" "goto" "end")
+    (token (string-downcase lexeme)
+           (string-downcase lexeme)
+           #:position (pos lexeme-start)
+           #:line (line lexeme-start)
+           #:column (col lexeme-start)
+           #:span (- (pos lexeme-end)
+                     (pos lexeme-start)))]
+   [(:+ numeric)
+    (token 'NUMBER
+           (string->number lexeme)
+           #:position (pos lexeme-start)
+           #:line (line lexeme-start)
+           #:column (col lexeme-start)
+           #:span (- (pos lexeme-end)
+                     (pos lexeme-start)))]
+   [(from/to "\"" "\"")
+    (token 'STRING
+           (trim-ends  "\"" lexeme "\"")
+           #:position (pos lexeme-start)
+           #:line (line lexeme-start)
+           #:column (col lexeme-start)
+           #:span (- (pos lexeme-end)
+                     (pos lexeme-start)))]))
 
 (define (tokenize ip)
   (port-count-lines! ip)
-  (define (next-token)
-    (define get-token
-      (lexer-src-pos
-       [(eof) eof]
-       [whitespace (token 'WHITE lexeme #:skip? #t)]
-       [(from/to "/*" "*/") (token 'COMMENT lexeme #:skip? #t)]
-       [(:: positive-number (:+ whitespace) (from/to (uc+lc "rem") "\n")) (token 'COMMENT lexeme #:skip? #t)]
-       [(:or (uc+lc "print" "for" "to" "step" "if"
-                   "goto" "input" "let" "next"
-                   "return" "clear" "list" "run"
-                   "end" "then" "else" "gosub"
-                   "and" "or" "stop" "let" "def" "dim" "on")
-            ";" "=" "(" ")" "+" "-" "*" "/" "^"
-            "<=" ">=" "<>" "<" ">" "=" ":" ",") (string-downcase lexeme)]
-       [positive-number (token 'NUMBER (string->number lexeme)
-                               #:position (pos lexeme-start)
-                               #:line (line lexeme-start)
-                               #:column (col lexeme-start)
-                               #:span (- (pos lexeme-end)
-                                         (pos lexeme-start)))]
-       [(:: alphabetic (:* (:or alphabetic numeric)) (:? "$")) (token 'ID (string->symbol lexeme)
-                                                                  #:position (pos lexeme-start)
-                                                                  #:line (line lexeme-start)
-                                                                  #:column (col lexeme-start)
-                                                                  #:span (- (pos lexeme-end)
-                                                                            (pos lexeme-start)))]
-       [(from/to "\"" "\"") (token 'STRING (trim-ends  "\"" lexeme  "\"")
-                                   #:position (+ (pos lexeme-start) 1)
-                                   #:line (line lexeme-start)
-                                   #:column (+ (col lexeme-start) 1)
-                                   #:span (- (pos lexeme-end)
-                                             (pos lexeme-start) 2))]))
-    (get-token ip))  
-  next-token)
+  (thunk (basic-lexer ip)))

beautiful-racket-lib/br/exception.rkt

@@ -0,0 +1,28 @@
+#lang racket/base
+(require (for-syntax racket/base br/syntax) br/define racket/match)
+(provide (all-defined-out))
+
+(define-macro (define-exn EXN-ID BASE-EXN)
+  (with-pattern ([RAISE-EXN-ID (prefix-id "raise-" #'EXN-ID)])
+    #'(begin
+        (struct EXN-ID BASE-EXN () #:transparent)
+        (define (RAISE-EXN-ID)
+          (raise (EXN-ID (format "error: ~a" 'EXN-ID) (current-continuation-marks)))))))
+
+(define-macro (define-exn-srcloc EXN-ID BASE-EXN)
+  (with-pattern ([RAISE-EXN-ID (prefix-id "raise-" #'EXN-ID)])
+    #'(begin
+        (define-struct (EXN-ID BASE-EXN)
+          (a-srcloc) #:transparent
+          #:property prop:exn:srclocs
+          (lambda (a-struct)
+            (match a-struct
+              [(struct EXN-ID
+                 (msg marks a-srcloc))
+               (list a-srcloc)])))
+        (define RAISE-EXN-ID
+          (case-lambda
+            [(srcloc)
+             (raise (EXN-ID (format "error: ~a" 'EXN-ID) (current-continuation-marks) srcloc))]
+            [()
+             (raise (EXN-ID (format "error: ~a" 'EXN-ID) (current-continuation-marks)))])))))

beautiful-racket-lib/br/main.rkt

@@ -1,10 +1,10 @@
 #lang racket/base
 (require racket/provide racket/list racket/string racket/format racket/match racket/port  racket/function
-         br/define br/syntax br/datum br/debug br/cond br/case br/list racket/class racket/vector br/reader-utils
+         br/define br/syntax br/datum br/debug br/cond br/case br/exception br/list racket/class racket/vector br/reader-utils
          (for-syntax racket/base racket/syntax br/syntax br/debug br/define br/datum))
 (provide (all-from-out racket/base)
          (all-from-out racket/list racket/string racket/format racket/match racket/port racket/function
-                       br/syntax br/datum br/debug br/cond br/case br/list racket/class racket/vector br/define br/reader-utils)
+                       br/syntax br/datum br/debug br/cond br/case br/exception br/list racket/class racket/vector br/define br/reader-utils)
          (for-syntax (all-from-out racket/base racket/syntax br/syntax br/debug br/datum))
          (for-syntax caller-stx with-shared-id)) ; from br/define
          

beautiful-racket-lib/br/syntax.rkt

@@ -115,4 +115,11 @@
   (define x (syntax-property* #'foo ['bar #t] ['zam 'boni]))
   (check-false (syntax-property* x 'foo))
   (check-true (syntax-property* x 'bar))
-  (check-equal? (syntax-property* x 'foo 'bar 'zam) '(#f #t boni)))
+  (check-equal? (syntax-property* x 'foo 'bar 'zam) '(#f #t boni)))
+
+(define (syntax-srcloc stx)
+  (srcloc (syntax-source stx)
+          (syntax-line stx)
+          (syntax-column stx)
+          (syntax-position stx)
+          (syntax-span stx)))