This source listing assumes that we’ve created a basic directory and installed it as a package as described in the specification and setup for the first basic tutorial.
#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" "def" "," "import" "export"))
(define-lex-abbrev racket-id-kapu
(:or whitespace (char-set "()[]{}\",'`;#|\\")))
(define basic-lexer
(lexer-srcloc
["\n" (token 'NEWLINE lexeme)]
[whitespace (token lexeme #:skip? #t)]
[(from/stop-before "rem" "\n") (token 'REM lexeme)]
[(:seq "[" (:+ (:~ racket-id-kapu)) "]")
(token 'RACKET-ID
(string->symbol (trim-ends "[" 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-statement /NEWLINE
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-def | b-import | b-export
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-def : /"def" b-id /"(" ID [/"," ID]* /")" /"=" b-expr
b-import : /"import" b-import-name
@b-import-name : RACKET-ID | STRING
b-export : /"export" b-export-name
@b-export-name : 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-func
b-func : (ID | RACKET-ID) /"(" b-expr [/"," b-expr]* /")"
@b-number : INTEGER | DECIMAL
b-repl : (b-statement | b-expr) (/":" [@b-repl])*
#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" "setup.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-property 'b-id #'(LINE ...))]
[(IMPORT-NAME ...)
(find-property 'b-import-name #'(LINE ...))]
[(EXPORT-NAME ...)
(find-property 'b-export-name #'(LINE ...))]
[((SHELL-ID SHELL-IDX) ...)
(make-shell-ids-and-idxs caller-stx)]
[(UNIQUE-ID ...)
(unique-ids
(syntax->list #'(VAR-ID ... SHELL-ID ...)))])
#'(#%module-begin
(module configure-runtime br
(require basic/setup)
(do-setup!))
(require IMPORT-NAME) ...
(provide EXPORT-NAME ...)
(define UNIQUE-ID 0) ...
(let ([clargs (current-command-line-arguments)])
(set! SHELL-ID (get-clarg clargs SHELL-IDX)) ...)
LINE ...
(define line-table
(apply hasheqv (append (list NUM LINE-FUNC) ...)))
(parameterize
([current-output-port (basic-output-port)])
(void (run line-table))))))
(define (get-clarg clargs idx)
(if (<= (vector-length clargs) idx)
0
(let ([val (vector-ref clargs idx)])
(or (string->number val) val))))
(begin-for-syntax
(require racket/list)
(define (unique-ids stxs)
(remove-duplicates stxs #:key syntax->datum))
(define (find-property which line-stxs)
(unique-ids
(for/list ([stx (in-list (stx-flatten line-stxs))]
#:when (syntax-property stx which))
stx)))
(define (make-shell-ids-and-idxs ctxt)
(define arg-count 10)
(for/list ([idx (in-range arg-count)])
(list (suffix-id #'arg idx #:context ctxt) idx))))
#lang br
(require "parser.rkt" "tokenizer.rkt")
(provide basic-output-port do-setup!)
(define basic-output-port
(make-parameter (open-output-nowhere)))
(define repl-parse (make-rule-parser b-repl))
(define (read-one-line origin port)
(define one-line (read-line port))
(if (eof-object? one-line)
eof
(repl-parse
(make-tokenizer (open-input-string one-line)))))
(define (do-setup!)
(basic-output-port (current-output-port))
(current-read-interaction read-one-line))
#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
(require "line.rkt")
(provide b-expr b-sum b-product b-neg b-expt b-def b-func)
(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)])
(define-macro (b-def FUNC-ID VAR-ID ... EXPR)
(syntax-local-lift-expression
#'(set! FUNC-ID (λ (VAR-ID ...) EXPR))))
(define-macro (b-func FUNC-ID ARG ...)
#'(if (procedure? FUNC-ID)
(convert-result (FUNC-ID ARG ...))
(raise-line-error
(format "expected ~a to be a function, got ~v"
'FUNC-ID FUNC-ID))))
(define (convert-result result)
(cond
[(number? result) (b-expr result)]
[(string? result) result]
[(boolean? result) (if result 1 0)]
[else
(raise-line-error
(format "unknown data type: ~v" result))]))
#lang br
(require "struct.rkt" "expr.rkt")
(provide b-rem b-print b-let b-input b-import b-export b-repl)
(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))))
(define-macro (b-import NAME) #'(void))
(define-macro (b-export NAME) #'(void))
(define-macro (b-repl . ALL-INPUTS)
(with-pattern
([INPUTS (pattern-case-filter #'ALL-INPUTS
[(b-print . PRINT-ARGS)
#'(b-print . PRINT-ARGS)]
[(b-expr . EXPR-ARGS)
#'(b-print (b-expr . EXPR-ARGS))]
[(b-let ID VAL)
#'(define ID VAL)]
[(b-def FUNC-ID VAR-ID ... EXPR)
#'(define (FUNC-ID VAR-ID ...) EXPR)]
[ANYTHING-ELSE
#'(error 'invalid-repl-input)])])
#'(begin . INPUTS)))
#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)))])