boom
parent
bc5bcad98c
commit
15675c7558
@ -0,0 +1,4 @@
|
||||
#lang basic-demo
|
||||
10 rem 20
|
||||
20 x = 42
|
||||
25 print x
|
||||
@ -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))
|
||||
@ -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)))
|
||||
@ -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)
|
||||
@ -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)
|
||||
@ -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"))
|
||||
@ -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
|
||||
@ -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
|
||||
(define-exn-srcloc duplicate-line-number exn:fail)
|
||||
|
||||
(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 ...)))])
|
||||
(define-macro (b-module-begin (b-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 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)))
|
||||
|
||||
(define-macro-cases sum
|
||||
[(_ SUM) #'SUM]
|
||||
[(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)]
|
||||
[(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)])
|
||||
(struct $line (number thunk srcloc) #:transparent)
|
||||
|
||||
(define-macro-cases product
|
||||
[(_ "-" VALUE) #'(- VALUE)]
|
||||
[(_ VALUE) #'VALUE]
|
||||
[(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)]
|
||||
[(_ PRODUCT "/" VALUE) #'(/ PRODUCT VALUE)])
|
||||
(define-macro (b-line LINE-NUMBER STATEMENT)
|
||||
(with-pattern ([SRCLOC (syntax-srcloc caller-stx)])
|
||||
#'($line LINE-NUMBER (thunk STATEMENT) SRCLOC)))
|
||||
|
||||
(define-macro-cases power
|
||||
[(_ BASE) #'BASE]
|
||||
[(_ BASE POWER) #'(expt BASE POWER)])
|
||||
(define-macro (b-statement (PROC-NAME ARG ...))
|
||||
#'(begin (PROC-NAME ARG ...)))
|
||||
|
||||
(define-macro-cases maybe-negative-val
|
||||
[(_ "-" ID) #'(- ID)]
|
||||
[(_ ID) #'ID])
|
||||
(define (b-rem str) #f)
|
||||
(define (b-print str) (displayln str))
|
||||
(define (b-goto line-number) line-number)
|
||||
|
||||
(define print-list list)
|
||||
(define-exn end-program-signal exn:fail)
|
||||
(define (b-end) (raise-end-program-signal))
|
||||
|
||||
(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))))
|
||||
(define-exn-srcloc line-not-found exn:fail)
|
||||
|
||||
(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 (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)))))
|
||||
@ -0,0 +1,2 @@
|
||||
#lang br
|
||||
(require "basic-test.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"
|
||||
@ -0,0 +1,3 @@
|
||||
#lang br
|
||||
(provide (all-defined-out))
|
||||
(define current-print-status (make-parameter #t))
|
||||
@ -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))
|
||||
@ -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 (tokenize ip)
|
||||
(port-count-lines! ip)
|
||||
(define (next-token)
|
||||
(define get-token
|
||||
(define basic-lexer
|
||||
(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)
|
||||
[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)))]
|
||||
[(:: alphabetic (:* (:or alphabetic numeric)) (:? "$")) (token 'ID (string->symbol lexeme)
|
||||
[(: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)))]
|
||||
[(from/to "\"" "\"") (token 'STRING (trim-ends "\"" lexeme "\"")
|
||||
#:position (+ (pos lexeme-start) 1)
|
||||
[(:+ numeric)
|
||||
(token 'NUMBER
|
||||
(string->number lexeme)
|
||||
#:position (pos lexeme-start)
|
||||
#:line (line lexeme-start)
|
||||
#:column (+ (col lexeme-start) 1)
|
||||
#:column (col lexeme-start)
|
||||
#:span (- (pos lexeme-end)
|
||||
(pos lexeme-start) 2))]))
|
||||
(get-token ip))
|
||||
next-token)
|
||||
(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)
|
||||
(thunk (basic-lexer ip)))
|
||||
@ -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)))])))))
|
||||
Loading…
Reference in New Issue