Into the rapids: more basic

#lang br
(require brag/support)

(define-lex-abbrev digits (:+ (char-set "0123456789")))

(define-lex-abbrev reserved-terms (:or "print" "goto" "end" "+" ":" ";" "let" "=" "input" "-" "*" "/" "^" "mod" "(" ")" "if" "then" "else" "<" ">" "<>" "and" "or" "not" "gosub" "return" "for" "to" "step" "next"))

(define basic-lexer
  (lexer-srcloc
   ["\n" (token 'NEWLINE lexeme)]
   [whitespace (token lexeme #:skip? #t)]
   [(from/stop-before "rem" "\n") (token 'REM lexeme)]
   [reserved-terms (token lexeme 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)

#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)

#lang brag
b-program : [b-line] (/NEWLINE [b-line])*
b-line : b-line-num [b-statement] (/":" [b-statement])* [b-rem]
@b-line-num : INTEGER
b-rem : REM
@b-statement : b-end | b-print | b-goto
             | b-let | b-input | b-if
             | b-gosub | b-return | b-for | b-next
b-end : /"end"
b-print : /"print" [b-printable] (/";" [b-printable])*
@b-printable : STRING | b-expr
b-goto : /"goto" b-expr
b-let : [/"let"] b-id /"=" (STRING | b-expr)
b-if : /"if" b-expr /"then" (b-statement | b-expr)
                   [/"else" (b-statement | b-expr)]
b-input : /"input" b-id
@b-id : ID
b-gosub : /"gosub" b-expr
b-return : /"return"
b-for : /"for" b-id /"=" b-expr /"to" b-expr [/"step" b-expr]
b-next : /"next" b-id
b-expr : b-or-expr
b-or-expr : [b-or-expr "or"] b-and-expr
b-and-expr : [b-and-expr "and"] b-not-expr
b-not-expr : ["not"] b-comp-expr
b-comp-expr : [b-comp-expr ("="|"<"|">"|"<>")] b-sum
b-sum : [b-sum ("+"|"-")] b-product
b-product : [b-product ("*"|"/"|"mod")] b-neg
b-neg : ["-"] b-expt
b-expt : [b-expt ("^")] b-value
@b-value : b-number | b-id | /"(" b-expr /")"
@b-number : INTEGER | DECIMAL

#lang br/quicklang
(require "parser.rkt" "tokenizer.rkt")

(module+ reader
  (provide read-syntax get-info))

(define (read-syntax path port)
  (define parse-tree (parse path (make-tokenizer port path)))
  (strip-bindings
   #`(module basic-mod basic/expander
       #,parse-tree)))

(define (get-info port src-mod src-line src-col src-pos)
    (define (handle-query key default)
      (case key
        [(color-lexer)
         (dynamic-require 'basic/colorer 'basic-colorer)]
        [else default]))
    handle-query)

#lang br/quicklang
(require "struct.rkt" "run.rkt" "elements.rkt")
(provide (rename-out [b-module-begin #%module-begin])
         (all-from-out "elements.rkt"))

(define-macro (b-module-begin (b-program LINE ...))
  (with-pattern
      ([((b-line NUM STMT ...) ...) #'(LINE ...)]
       [(LINE-FUNC ...) (prefix-id "line-" #'(NUM ...))]
       [(VAR-ID ...) (find-unique-var-ids #'(LINE ...))])
    #'(#%module-begin
       (define VAR-ID 0) ...
       LINE ...
       (define line-table
         (apply hasheqv (append (list NUM LINE-FUNC) ...)))
       (void (run line-table)))))

(begin-for-syntax
  (require racket/list)
  (define (find-unique-var-ids line-stxs)
    (remove-duplicates
     (for/list ([stx (in-list (stx-flatten line-stxs))]
                #:when (syntax-property stx 'b-id))
       stx)
     #:key syntax->datum)))

#lang br
(provide (struct-out end-program-signal)
         (struct-out change-line-signal)
         (struct-out line-error))

(struct end-program-signal ())
(struct change-line-signal (val))
(struct line-error (msg))

#lang br
(require "line.rkt" "struct.rkt")
(provide run)

(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))
               (line-func #:error (format "line ~a not found" clsv))))])
        (line-func)
        (add1 line-idx)))))

#lang br
(require "line.rkt" "go.rkt"
         "expr.rkt" "misc.rkt" "cond.rkt")
(provide
 (all-from-out "line.rkt" "go.rkt"
               "expr.rkt" "misc.rkt" "cond.rkt"))

#lang br
(require "struct.rkt")
(provide b-line raise-line-error)

(define-macro (b-line NUM STATEMENT ...)
  (with-pattern ([LINE-NUM (prefix-id "line-" #'NUM
                                      #:source #'NUM)])
    (syntax/loc caller-stx
      (define (LINE-NUM #:error [msg #f])
        (with-handlers
            ([line-error?
              (λ (le) (handle-line-error NUM le))])
          (when msg (raise-line-error msg))
          STATEMENT ...)))))

(define (raise-line-error error-msg)
  (raise (line-error error-msg)))

(define (handle-line-error num le)
  (error (format "error in line ~a: ~a"
                 num (line-error-msg le))))

#lang br
(require "lexer.rkt" brag/support)
(provide basic-colorer)

(define (basic-colorer port)
  (define (handle-lexer-error excn)
    (define excn-srclocs (exn:fail:read-srclocs excn))
    (srcloc-token (token 'ERROR) (car excn-srclocs)))
  (define srcloc-tok
    (with-handlers ([exn:fail:read? handle-lexer-error])
      (basic-lexer port)))
  (match srcloc-tok
    [(? eof-object?) (values srcloc-tok 'eof #f #f #f)]
    [else
     (match-define
       (srcloc-token
        (token-struct type val _ _ _ _ _)
        (srcloc _ _ _ posn span)) srcloc-tok)
     (define start posn)
     (define end (+ start span))
     (match-define (list cat paren)
       (match type
         ['STRING '(string #f)]
         ['REM '(comment #f)]
         ['ERROR '(error #f)]
         [else (match val
                 [(? number?) '(constant #f)]
                 [(? symbol?) '(symbol #f)]
                 ["(" '(parenthesis |(|)]
                 [")" '(parenthesis |)|)]
                 [else '(no-color #f)])]))
     (values val cat paren start end)]))

#lang br
(require "struct.rkt" "line.rkt" "misc.rkt")
(provide b-end b-goto b-gosub b-return b-for b-next)

(define (b-end) (raise (end-program-signal)))

(define (b-goto num-expr)
  (raise (change-line-signal num-expr)))

(define return-ccs empty)

(define (b-gosub num-expr)
  (let/cc this-cc
    (push! return-ccs this-cc)
    (b-goto num-expr)))

(define (b-return)
  (when (empty? return-ccs)
    (raise-line-error "return without gosub"))
  (define top-cc (pop! return-ccs))
  (top-cc (void)))

(define next-funcs (make-hasheq))

(define-macro-cases b-for
  [(_ LOOP-ID START END) #'(b-for LOOP-ID START END 1)]
  [(_ LOOP-ID START END STEP)
   #'(b-let LOOP-ID
            (let/cc loop-cc
              (hash-set! next-funcs
                         'LOOP-ID
                         (λ ()
                           (define next-val
                             (+ LOOP-ID STEP))
                           (if (next-val
                                . in-closed-interval? .
                                START END)
                               (loop-cc next-val)
                               (hash-remove! next-funcs
                                             'LOOP-ID))))
              START))])

(define (in-closed-interval? x start end)
  ((if (< start end) <= >=) start x end))

(define-macro (b-next LOOP-ID)
  #'(begin
      (unless (hash-has-key? next-funcs 'LOOP-ID)
        (raise-line-error
         (format "`next ~a` without for" 'LOOP-ID)))
      (define func (hash-ref next-funcs 'LOOP-ID))
      (func)))

#lang br
(provide b-expr b-sum b-product b-neg b-expt)

(define (b-expr expr)
  (if (integer? expr) (inexact->exact expr) expr))

(define-macro-cases b-sum
  [(_ VAL) #'VAL]
  [(_ LEFT "+" RIGHT) #'(+ LEFT RIGHT)]
  [(_ LEFT "-" RIGHT) #'(- LEFT RIGHT)])

(define-macro-cases b-product
  [(_ VAL) #'VAL]
  [(_ LEFT "*" RIGHT) #'(* LEFT RIGHT)]
  [(_ LEFT "/" RIGHT) #'(/ LEFT RIGHT 1.0)]
  [(_ LEFT "mod" RIGHT) #'(modulo LEFT RIGHT)])

(define-macro-cases b-neg
  [(_ VAL) #'VAL]
  [(_ "-" VAL) #'(- VAL)])

(define-macro-cases b-expt
  [(_ VAL) #'VAL]
  [(_ LEFT "^" RIGHT) #'(expt LEFT RIGHT)])

#lang br
(require "struct.rkt")
(provide b-rem b-print b-let b-input)

(define (b-rem val) (void))

(define (b-print . vals)
  (displayln (string-append* (map ~a vals))))

(define-macro (b-let ID VAL) #'(set! ID VAL))

(define-macro (b-input ID)
  #'(b-let ID (let* ([str (read-line)]
                     [num (string->number (string-trim str))])
                (or num str))))

#lang br
(require "go.rkt")
(provide b-if b-or-expr b-and-expr b-not-expr b-comp-expr)

(define (bool->int val) (if val 1 0))
(define nonzero? (compose1 not zero?))

(define-macro-cases b-or-expr
  [(_ VAL) #'VAL]
  [(_ LEFT "or" RIGHT)
   #'(bool->int (or (nonzero? LEFT) (nonzero? RIGHT)))])

(define-macro-cases b-and-expr
  [(_ VAL) #'VAL]
  [(_ LEFT "and" RIGHT)
   #'(bool->int (and (nonzero? LEFT) (nonzero? RIGHT)))])

(define-macro-cases b-not-expr
  [(_ VAL) #'VAL]
  [(_ "not" VAL) #'(if (nonzero? VAL) 0 1)])

(define b= (compose1 bool->int =))
(define b< (compose1 bool->int <))
(define b> (compose1 bool->int >))
(define b<> (compose1 bool->int not =))

(define-macro-cases b-comp-expr
  [(_ VAL) #'VAL]
  [(_ LEFT "=" RIGHT) #'(b= LEFT RIGHT)]
  [(_ LEFT "<" RIGHT) #'(b< LEFT RIGHT)]
  [(_ LEFT ">" RIGHT) #'(b> LEFT RIGHT)]
  [(_ LEFT "<>" RIGHT) #'(b<> LEFT RIGHT)])

(define-macro-cases b-if
  [(_ COND-EXPR THEN-EXPR) #'(b-if COND-EXPR THEN-EXPR (void))]
  [(_ COND-EXPR THEN-EXPR ELSE-EXPR)
   #'(let ([result (if (nonzero? COND-EXPR)
                       THEN-EXPR
                       ELSE-EXPR)])
       (when (exact-positive-integer? result)
         (b-goto result)))])