sense being made
This commit is contained in:
Matthew Butterick
parent
67a16a6b1d
commit
d6baa0508e
|
|
@ -1,20 +1,26 @@
|
||||||
#lang br
|
#lang br
|
||||||
(provide (all-defined-out)
|
(provide #%top-interaction #%app #%datum
|
||||||
#%top-interaction
|
(rename-out [basic-module-begin #%module-begin])
|
||||||
#%datum
|
(rename-out [basic-top #%top])
|
||||||
(rename-out [basic-module-begin #%module-begin]))
|
(all-defined-out))
|
||||||
(require (for-syntax racket/string))
|
(require (for-syntax racket/syntax))
|
||||||
|
|
||||||
(define #'(basic-module-begin PARSE-TREE ...)
|
(define #'(basic-module-begin PARSE-TREE ...)
|
||||||
#'(#%module-begin
|
#'(#%module-begin
|
||||||
(println (quote PARSE-TREE ...))
|
(println (quote PARSE-TREE ...))
|
||||||
'PARSE-TREE ...))
|
PARSE-TREE ...))
|
||||||
|
|
||||||
(define #'(basic-program LINE ...)
|
; #%app and #%datum have to be present to make #%top work
|
||||||
#'(basic-run LINE ...))
|
(define #'(basic-top . id)
|
||||||
|
#'(begin
|
||||||
|
(displayln (format "got unbound identifier: ~a" 'id))
|
||||||
|
(procedure-rename (λ xs (cons 'id xs)) (format-datum "undefined:~a" 'id))))
|
||||||
|
|
||||||
|
(define #'(basic-program CR-LINE ...)
|
||||||
|
#'(begin CR-LINE ...))
|
||||||
|
|
||||||
(define (basic-run . lines)
|
(define (basic-run . lines)
|
||||||
(define program-lines (list->vector (filter (λ(x) x) lines)))
|
(define program-lines (list->vector lines))
|
||||||
(void (for/fold ([line-idx 0])
|
(void (for/fold ([line-idx 0])
|
||||||
([i (in-naturals)]
|
([i (in-naturals)]
|
||||||
#:break (= line-idx (vector-length program-lines)))
|
#:break (= line-idx (vector-length program-lines)))
|
||||||
|
|
@ -28,60 +34,47 @@
|
||||||
idx)))
|
idx)))
|
||||||
(add1 line-idx)))))
|
(add1 line-idx)))))
|
||||||
|
|
||||||
(define #'(CR) #'#f)
|
(define-cases #'cr-line ; erases "cr"s
|
||||||
|
[#'(_ "cr" LINE) #'LINE]
|
||||||
|
[#'(_ "cr") #'(begin)])
|
||||||
|
|
||||||
(define #'(REM ARG ...) #'(void (list 'ARG ...)))
|
(define #'(line NUMBER STATEMENT ...)
|
||||||
|
#'(begin STATEMENT ...))
|
||||||
|
|
||||||
;; model each line as (cons line-number line-thunk)
|
(define-cases #'statement
|
||||||
(define-cases #'line
|
[#'(statement ID "=" EXPR) (if (identifier-binding #'ID)
|
||||||
[#'(_ NUMBER . SEPARATED-STMTS)
|
#'(set! ID EXPR)
|
||||||
#`(cons NUMBER
|
#'(define ID EXPR))]
|
||||||
(λ _ (begin
|
[#'(statement PROC ARG ...) #'(PROC ARG ...)])
|
||||||
#,@(for/list ([(item idx) (in-indexed (syntax->list #'SEPARATED-STMTS))]
|
|
||||||
#:when (even? idx))
|
|
||||||
item))))]
|
|
||||||
[#'(_ ARG ...) #'(line #f ARG ...)])
|
|
||||||
|
|
||||||
(define #'(statement NAME ARG ...) #'(NAME ARG ...))
|
(define-cases #'value
|
||||||
|
[#'(value "(" EXPR ")") #'EXPR]
|
||||||
|
[#'(value ID "(" ARG ... ")") #'(ID ARG ...)]
|
||||||
|
[#'(value DATUM) #'DATUM])
|
||||||
|
|
||||||
(define #'(expression ITEM) #'ITEM)
|
(define #'(expr EXPR) #'EXPR)
|
||||||
(define #'(unsignedexpr ITEM) #'ITEM)
|
|
||||||
(define #'(term ITEM) #'ITEM)
|
|
||||||
(define #'(factor ITEM) #'ITEM)
|
|
||||||
(define #'(number ITEM) #'ITEM)
|
|
||||||
(define #'(varlist ITEM) #'ITEM)
|
|
||||||
(define #'(var ITEM) #'ITEM)
|
|
||||||
|
|
||||||
|
(define-cases sum
|
||||||
|
[(_ term op sum) (op term sum)]
|
||||||
|
[(_ term) term])
|
||||||
|
(provide - +)
|
||||||
|
|
||||||
(define #'(printitem EXPR-OR-STRING) #'EXPR-OR-STRING)
|
(define-cases product
|
||||||
|
[(_ factor op product) (op factor product)]
|
||||||
|
[(_ factor) factor])
|
||||||
|
(provide * /)
|
||||||
|
|
||||||
;; skip separators
|
(define print-list list)
|
||||||
(define #'(printlist . SEPARATED-ITEMS) #`(list #,@(for/list ([(item idx) (in-indexed (syntax->list #'SEPARATED-ITEMS))]
|
|
||||||
#:when (even? idx))
|
|
||||||
item)))
|
|
||||||
|
|
||||||
(define #'(separator SEP) #'(void))
|
(define (PRINT args)
|
||||||
|
(match args
|
||||||
|
[(list) (displayln "")]
|
||||||
|
[(list items ... ";" pl) (begin (for-each display items) (PRINT pl))]
|
||||||
|
[(list items ... ";") (for-each display items)]
|
||||||
|
[(list items ...) (for-each displayln items)]))
|
||||||
|
|
||||||
(define #'(function NAME EXP ")") #`(#,(string->symbol (string-trim (syntax->datum #'NAME) "(")) EXP))
|
(define (TAB num) (make-string num #\space))
|
||||||
|
(define (INT num) (inexact->exact (round num)))
|
||||||
(define (TAB expr)
|
(define (SIN num) (sin num))
|
||||||
(make-string expr #\space))
|
|
||||||
|
|
||||||
(define (PRINT . args)
|
|
||||||
(println args)
|
|
||||||
(if (and (= (length args) 1) (list? (car args)))
|
|
||||||
(begin
|
|
||||||
(for-each display (car args))
|
|
||||||
(displayln ""))
|
|
||||||
(filter (λ(i) (and (equal? i ":") (displayln ""))) args)))
|
|
||||||
|
|
||||||
(define (GOTO where)
|
|
||||||
where)
|
|
||||||
|
|
||||||
(define vars (make-hasheq))
|
|
||||||
(define (INPUT id)
|
|
||||||
(hash-set! vars (string->symbol id) (read (open-input-string (read-line)))))
|
|
||||||
|
|
||||||
(define-cases #'expr-list
|
|
||||||
[#'(_ EXPR ...) #'(list EXPR ...)])
|
|
||||||
|
|
||||||
|
(define (comment . args) void)
|
||||||
|
|
|
||||||
87
beautiful-racket/br/demo/basic/expander0.rkt
Normal file
87
beautiful-racket/br/demo/basic/expander0.rkt
Normal file
|
|
@ -0,0 +1,87 @@
|
||||||
|
#lang br
|
||||||
|
(provide (all-defined-out)
|
||||||
|
#%top-interaction
|
||||||
|
#%datum
|
||||||
|
(rename-out [basic-module-begin #%module-begin]))
|
||||||
|
(require (for-syntax racket/string))
|
||||||
|
|
||||||
|
(define #'(basic-module-begin PARSE-TREE ...)
|
||||||
|
#'(#%module-begin
|
||||||
|
(println (quote PARSE-TREE ...))
|
||||||
|
'PARSE-TREE ...))
|
||||||
|
|
||||||
|
(define #'(basic-program LINE ...)
|
||||||
|
#'(basic-run LINE ...))
|
||||||
|
|
||||||
|
(define (basic-run . lines)
|
||||||
|
(define program-lines (list->vector (filter (λ(x) x) lines)))
|
||||||
|
(void (for/fold ([line-idx 0])
|
||||||
|
([i (in-naturals)]
|
||||||
|
#:break (= line-idx (vector-length program-lines)))
|
||||||
|
(match-define (cons line-number proc)
|
||||||
|
(vector-ref program-lines line-idx))
|
||||||
|
(define maybe-jump-number (and proc (proc)))
|
||||||
|
(if (number? maybe-jump-number)
|
||||||
|
(let ([jump-number maybe-jump-number])
|
||||||
|
(for/or ([idx (in-range (vector-length program-lines))])
|
||||||
|
(and (= (car (vector-ref program-lines idx)) jump-number)
|
||||||
|
idx)))
|
||||||
|
(add1 line-idx)))))
|
||||||
|
|
||||||
|
(define #'(CR) #'#f)
|
||||||
|
|
||||||
|
(define #'(REM ARG ...) #'(void (list 'ARG ...)))
|
||||||
|
|
||||||
|
;; model each line as (cons line-number line-thunk)
|
||||||
|
(define-cases #'line
|
||||||
|
[#'(_ NUMBER . SEPARATED-STMTS)
|
||||||
|
#`(cons NUMBER
|
||||||
|
(λ _ (begin
|
||||||
|
#,@(for/list ([(item idx) (in-indexed (syntax->list #'SEPARATED-STMTS))]
|
||||||
|
#:when (even? idx))
|
||||||
|
item))))]
|
||||||
|
[#'(_ ARG ...) #'(line #f ARG ...)])
|
||||||
|
|
||||||
|
(define #'(statement NAME ARG ...) #'(NAME ARG ...))
|
||||||
|
|
||||||
|
(define #'(expression ITEM) #'ITEM)
|
||||||
|
(define #'(unsignedexpr ITEM) #'ITEM)
|
||||||
|
(define #'(term ITEM) #'ITEM)
|
||||||
|
(define #'(factor ITEM) #'ITEM)
|
||||||
|
(define #'(number ITEM) #'ITEM)
|
||||||
|
(define #'(varlist ITEM) #'ITEM)
|
||||||
|
(define #'(var ITEM) #'ITEM)
|
||||||
|
|
||||||
|
|
||||||
|
(define #'(printitem EXPR-OR-STRING) #'EXPR-OR-STRING)
|
||||||
|
|
||||||
|
;; skip separators
|
||||||
|
(define #'(printlist . SEPARATED-ITEMS) #`(list #,@(for/list ([(item idx) (in-indexed (syntax->list #'SEPARATED-ITEMS))]
|
||||||
|
#:when (even? idx))
|
||||||
|
item)))
|
||||||
|
|
||||||
|
(define #'(separator SEP) #'(void))
|
||||||
|
|
||||||
|
(define #'(function NAME EXP ")") #`(#,(string->symbol (string-trim (syntax->datum #'NAME) "(")) EXP))
|
||||||
|
|
||||||
|
(define (TAB expr)
|
||||||
|
(make-string expr #\space))
|
||||||
|
|
||||||
|
(define (PRINT . args)
|
||||||
|
(println args)
|
||||||
|
(if (and (= (length args) 1) (list? (car args)))
|
||||||
|
(begin
|
||||||
|
(for-each display (car args))
|
||||||
|
(displayln ""))
|
||||||
|
(filter (λ(i) (and (equal? i ":") (displayln ""))) args)))
|
||||||
|
|
||||||
|
(define (GOTO where)
|
||||||
|
where)
|
||||||
|
|
||||||
|
(define vars (make-hasheq))
|
||||||
|
(define (INPUT id)
|
||||||
|
(hash-set! vars (string->symbol id) (read (open-input-string (read-line)))))
|
||||||
|
|
||||||
|
(define-cases #'expr-list
|
||||||
|
[#'(_ EXPR ...) #'(list EXPR ...)])
|
||||||
|
|
||||||
|
|
@ -1,62 +1,32 @@
|
||||||
#lang ragg
|
#lang ragg
|
||||||
;; adapted from http://www.ittybittycomputers.com/IttyBitty/TinyBasic/TBuserMan.txt
|
|
||||||
|
|
||||||
;; MS Basic extensions
|
basic-program : cr-line* [CR]
|
||||||
;; http://www.atariarchives.org/basicgames/showpage.php?page=i12
|
|
||||||
|
|
||||||
;; games
|
cr-line : CR line [cr-line]
|
||||||
;; http://www.vintage-basic.net/games.html
|
|
||||||
|
|
||||||
;; chipmunk basic
|
line: INTEGER statement+
|
||||||
;; http://www.nicholson.com/rhn/basic/basic.man.html
|
|
||||||
|
|
||||||
basic-program : [CR] lines [CR]
|
statement : "END"
|
||||||
|
|
||||||
lines : INTEGER statements [CR | CR lines]
|
|
||||||
|
|
||||||
statements : statement [":" statements]
|
|
||||||
|
|
||||||
statement : "CLOSE" "#" INTEGER
|
|
||||||
| "END"
|
|
||||||
| "FOR" ID "=" expr "TO" expr ["STEP" expr]
|
| "FOR" ID "=" expr "TO" expr ["STEP" expr]
|
||||||
| "GOTO" expr
|
| "GOTO" expr
|
||||||
| "IF" expr "THEN" (statement | expr) ; change: add expr
|
| "IF" expr "THEN" (statement | expr) ; change: add expr
|
||||||
| "INPUT" id-list
|
| "INPUT" ID+
|
||||||
| ["LET"] ID "=" expr ; change: make "LET" opt
|
| ["LET"] ID "=" expr ; change: make "LET" opt
|
||||||
| "NEXT" id-list
|
| "NEXT" ID+
|
||||||
| "PRINT" printlist
|
| "PRINT" print-list
|
||||||
| "REM" STRING
|
| REM-COMMENT
|
||||||
|
|
||||||
id-list : ID ["," id-list]
|
print-list : [expr [";" [print-list]*]]
|
||||||
|
|
||||||
value-list : value ["," value-list]
|
expr : sum [("=" | "<>" | "><" | ">" | ">=" | "<" | "<=") expr]
|
||||||
|
|
||||||
constant-list : constant ["," constant-list]
|
sum : product [("+" | "-") sum]+
|
||||||
|
|
||||||
integer-list : INTEGER ["," integer-list]
|
product : value [("*" | "/") product]+
|
||||||
|
|
||||||
expr-list : expr ["," expr-list]
|
|
||||||
|
|
||||||
printlist : [expr [";" printlist]]
|
|
||||||
|
|
||||||
expr : and-expr ["OR" expr]
|
|
||||||
|
|
||||||
and-expr : not-expr ["AND" and-expr]
|
|
||||||
|
|
||||||
not-expr : ["NOT"] compare-expr
|
|
||||||
|
|
||||||
compare-expr : add-expr [("=" | "<>" | "><" | ">" | ">=" | "<" | "<=") compare-expr]
|
|
||||||
|
|
||||||
add-expr : mult-expr [("+" | "-") add-expr]
|
|
||||||
|
|
||||||
mult-expr : negate-expr [("*" | "/") mult-expr]
|
|
||||||
|
|
||||||
negate-expr : ["-"] power-expr
|
|
||||||
|
|
||||||
power-expr : [power-expr "^"] value
|
|
||||||
|
|
||||||
value : "(" expr ")"
|
value : "(" expr ")"
|
||||||
| ID ["(" expr-list ")"]
|
| ID ["(" expr* ")"]
|
||||||
| constant
|
| INTEGER
|
||||||
|
| STRING
|
||||||
|
| REAL
|
||||||
|
|
||||||
constant : INTEGER | STRING | REAL
|
|
||||||
|
|
|
||||||
61
beautiful-racket/br/demo/basic/parser0.rkt
Normal file
61
beautiful-racket/br/demo/basic/parser0.rkt
Normal file
|
|
@ -0,0 +1,61 @@
|
||||||
|
#lang ragg
|
||||||
|
;; adapted from http://www.ittybittycomputers.com/IttyBitty/TinyBasic/TBuserMan.txt
|
||||||
|
|
||||||
|
;; MS Basic extensions
|
||||||
|
;; http://www.atariarchives.org/basicgames/showpage.php?page=i12
|
||||||
|
|
||||||
|
;; games
|
||||||
|
;; http://www.vintage-basic.net/games.html
|
||||||
|
|
||||||
|
;; chipmunk basic
|
||||||
|
;; http://www.nicholson.com/rhn/basic/basic.man.html
|
||||||
|
|
||||||
|
basic-program : [CR] line [CR line]* [CR]
|
||||||
|
|
||||||
|
line: INTEGER statements
|
||||||
|
|
||||||
|
statements : statement [":" statement]*
|
||||||
|
|
||||||
|
statement : "END"
|
||||||
|
| "FOR" ID "=" expr "TO" expr ["STEP" expr]
|
||||||
|
| "GOTO" expr
|
||||||
|
| "IF" expr "THEN" (statement | expr) ; change: add expr
|
||||||
|
| "INPUT" id-list
|
||||||
|
| ["LET"] ID "=" expr ; change: make "LET" opt
|
||||||
|
| "NEXT" id-list
|
||||||
|
| "PRINT" print-list
|
||||||
|
| "REM" STRING
|
||||||
|
|
||||||
|
id-list : ID ["," id-list]
|
||||||
|
|
||||||
|
;value-list : value ["," value]*
|
||||||
|
|
||||||
|
;datum-list : datum ["," datum]*
|
||||||
|
|
||||||
|
;integer-list : INTEGER ["," INTEGER]*
|
||||||
|
|
||||||
|
expr-list : expr ["," expr]*
|
||||||
|
|
||||||
|
print-list : [expr [";" print-list]]
|
||||||
|
|
||||||
|
;expr : and-expr ["OR" expr]
|
||||||
|
;and-expr : not-expr ["AND" and-expr]
|
||||||
|
;not-expr : ["NOT"] compare-expr
|
||||||
|
;compare-expr : term [("=" | "<>" | "><" | ">" | ">=" | "<" | "<=") compare-expr]
|
||||||
|
|
||||||
|
expr : term [("=" | "<>" | "><" | ">" | ">=" | "<" | "<=") expr]
|
||||||
|
|
||||||
|
|
||||||
|
term : factor [("+" | "-") term]
|
||||||
|
|
||||||
|
factor : value [("*" | "/") factor]
|
||||||
|
|
||||||
|
;negate-expr : ["-"] power-expr
|
||||||
|
|
||||||
|
;power-expr : [power-expr "^"] value
|
||||||
|
|
||||||
|
value : "(" expr ")"
|
||||||
|
| ID ["(" expr-list ")"]
|
||||||
|
| datum
|
||||||
|
|
||||||
|
datum : INTEGER | STRING | REAL
|
||||||
|
|
@ -1,16 +1,3 @@
|
||||||
#lang br/demo/basic
|
#lang br/demo/basic
|
||||||
10 PRINT TAB(30);"SINE WAVE"
|
10 PRINT TAB(30);"SINE WAVE"
|
||||||
20 PRINT TAB(15);"CREATIVE COMPUTING MORRISTOWN, NEW JERSEY"
|
20 PRINT TAB(15);"CREATIVE COMPUTING MORRISTOWN, NEW JERSEY"
|
||||||
30 PRINT: PRINT: PRINT: PRINT: PRINT
|
|
||||||
50 B=0
|
|
||||||
110 FOR T=0 TO 40 STEP .25
|
|
||||||
120 A=INT(26+25*SIN(T))
|
|
||||||
130 PRINT TAB(A);
|
|
||||||
140 IF B=1 THEN 180
|
|
||||||
150 PRINT "CREATIVE"
|
|
||||||
160 B=1
|
|
||||||
170 GOTO 200
|
|
||||||
180 PRINT "COMPUTING"
|
|
||||||
190 B=0
|
|
||||||
200 NEXT T
|
|
||||||
999 END
|
|
||||||
|
|
@ -9,18 +9,26 @@
|
||||||
(define (next-token)
|
(define (next-token)
|
||||||
(define get-token
|
(define get-token
|
||||||
(lexer
|
(lexer
|
||||||
[(repetition 1 +inf.0 "\n") (token 'CR '(CR))]
|
[(:seq "REM" (repetition 1 +inf.0 (char-complement "\n")))
|
||||||
[(union "PRINT" "FOR" "TO" "STEP" "IF" "THEN" "GOTO" "REM"
|
(token 'REM-COMMENT (format-datum '(comment "~v") lexeme))]
|
||||||
|
[(repetition 1 +inf.0 "\n") (token 'CR "cr")]
|
||||||
|
[(union "PRINT" "FOR" "TO" "STEP" "IF" "THEN" "GOTO"
|
||||||
"INPUT" "LET" "NEXT" "GOSUB" "RETURN"
|
"INPUT" "LET" "NEXT" "GOSUB" "RETURN"
|
||||||
"CLEAR" "LIST" "RUN" "END") (string->symbol lexeme)]
|
"CLEAR" "LIST" "RUN" "END") (string->symbol lexeme)]
|
||||||
|
|
||||||
;; this only matches integers
|
;; this only matches integers
|
||||||
[(repetition 1 +inf.0 numeric) (token 'INTEGER (string->number lexeme))]
|
[(repetition 1 +inf.0 numeric) (token 'INTEGER (string->number lexeme))]
|
||||||
[(repetition 1 +inf.0 (union "." numeric)) (token 'REAL (string->number lexeme))]
|
[(repetition 1 +inf.0 (union "." numeric)) (token 'REAL (string->number lexeme))]
|
||||||
[(union "," ";" ":" "+" "-" "*" "/"
|
;; things that get thrown out: pass through as strings,
|
||||||
"<=" ">=" "<>" "><" "<" ">" "=" "(" ")") lexeme]
|
;; because they can be matched literally in macros.
|
||||||
[(:seq (repetition 1 +inf.0 upper-case)) (token 'ID lexeme)]
|
;; things that become identifiers: pass through as symbols,
|
||||||
[upper-case (token 'UPPERCASE lexeme)]
|
;; so they can get bound by the expander.
|
||||||
|
[(union "," ":") (token 'SEPARATOR lexeme #:skip? #t)]
|
||||||
|
[(union ";" "=" "(" ")") lexeme]
|
||||||
|
[(union "+" "-" "*" "/"
|
||||||
|
"<=" ">=" "<>" "><" "<" ">" "=" ) (string->symbol lexeme)]
|
||||||
|
[(:seq (repetition 1 +inf.0 upper-case)) (token 'ID (string->symbol lexeme))]
|
||||||
|
[upper-case (token 'UPPERCASE (string->symbol lexeme))]
|
||||||
[whitespace (token 'WHITESPACE lexeme #:skip? #t)]
|
[whitespace (token 'WHITESPACE lexeme #:skip? #t)]
|
||||||
[(:seq "\"" (complement (:: any-string "\"" any-string)) "\"") (token 'STRING (string-trim lexeme "\""))]
|
[(:seq "\"" (complement (:: any-string "\"" any-string)) "\"") (token 'STRING (string-trim lexeme "\""))]
|
||||||
[(eof) eof]))
|
[(eof) eof]))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user