From d6baa0508e4317944c6b09ae633755124a682da4 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 19 Apr 2016 12:38:02 -0700 Subject: [PATCH] sense being made --- beautiful-racket/br/demo/basic/expander.rkt | 105 +++++++++---------- beautiful-racket/br/demo/basic/expander0.rkt | 87 +++++++++++++++ beautiful-racket/br/demo/basic/parser.rkt | 62 +++-------- beautiful-racket/br/demo/basic/parser0.rkt | 61 +++++++++++ beautiful-racket/br/demo/basic/sinewave.bas | 13 --- beautiful-racket/br/demo/basic/tokenizer.rkt | 20 ++-- 6 files changed, 227 insertions(+), 121 deletions(-) create mode 100644 beautiful-racket/br/demo/basic/expander0.rkt create mode 100644 beautiful-racket/br/demo/basic/parser0.rkt diff --git a/beautiful-racket/br/demo/basic/expander.rkt b/beautiful-racket/br/demo/basic/expander.rkt index a9a55e2..a67c7cd 100644 --- a/beautiful-racket/br/demo/basic/expander.rkt +++ b/beautiful-racket/br/demo/basic/expander.rkt @@ -1,20 +1,26 @@ #lang br -(provide (all-defined-out) - #%top-interaction - #%datum - (rename-out [basic-module-begin #%module-begin])) -(require (for-syntax racket/string)) +(provide #%top-interaction #%app #%datum + (rename-out [basic-module-begin #%module-begin]) + (rename-out [basic-top #%top]) + (all-defined-out)) +(require (for-syntax racket/syntax)) (define #'(basic-module-begin PARSE-TREE ...) #'(#%module-begin (println (quote PARSE-TREE ...)) - 'PARSE-TREE ...)) + PARSE-TREE ...)) -(define #'(basic-program LINE ...) - #'(basic-run LINE ...)) +; #%app and #%datum have to be present to make #%top work +(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 program-lines (list->vector (filter (λ(x) x) lines))) + (define program-lines (list->vector lines)) (void (for/fold ([line-idx 0]) ([i (in-naturals)] #:break (= line-idx (vector-length program-lines))) @@ -28,60 +34,47 @@ 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-cases #'cr-line ; erases "cr"s + [#'(_ "cr" LINE) #'LINE] + [#'(_ "cr") #'(begin)]) -(define #'(printitem EXPR-OR-STRING) #'EXPR-OR-STRING) +(define #'(line NUMBER STATEMENT ...) + #'(begin STATEMENT ...)) -;; skip separators -(define #'(printlist . SEPARATED-ITEMS) #`(list #,@(for/list ([(item idx) (in-indexed (syntax->list #'SEPARATED-ITEMS))] - #:when (even? idx)) - item))) +(define-cases #'statement + [#'(statement ID "=" EXPR) (if (identifier-binding #'ID) + #'(set! ID EXPR) + #'(define ID EXPR))] + [#'(statement PROC ARG ...) #'(PROC ARG ...)]) -(define #'(separator SEP) #'(void)) +(define-cases #'value + [#'(value "(" EXPR ")") #'EXPR] + [#'(value ID "(" ARG ... ")") #'(ID ARG ...)] + [#'(value DATUM) #'DATUM]) -(define #'(function NAME EXP ")") #`(#,(string->symbol (string-trim (syntax->datum #'NAME) "(")) EXP)) +(define #'(expr EXPR) #'EXPR) -(define (TAB expr) - (make-string expr #\space)) +(define-cases sum + [(_ term op sum) (op term sum)] + [(_ term) term]) +(provide - +) -(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-cases product + [(_ factor op product) (op factor product)] + [(_ factor) factor]) +(provide * /) -(define (GOTO where) - where) +(define print-list list) -(define vars (make-hasheq)) -(define (INPUT id) - (hash-set! vars (string->symbol id) (read (open-input-string (read-line))))) +(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-cases #'expr-list - [#'(_ EXPR ...) #'(list EXPR ...)]) +(define (TAB num) (make-string num #\space)) +(define (INT num) (inexact->exact (round num))) +(define (SIN num) (sin num)) +(define (comment . args) void) diff --git a/beautiful-racket/br/demo/basic/expander0.rkt b/beautiful-racket/br/demo/basic/expander0.rkt new file mode 100644 index 0000000..a9a55e2 --- /dev/null +++ b/beautiful-racket/br/demo/basic/expander0.rkt @@ -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 ...)]) + diff --git a/beautiful-racket/br/demo/basic/parser.rkt b/beautiful-racket/br/demo/basic/parser.rkt index 220956b..63138ff 100644 --- a/beautiful-racket/br/demo/basic/parser.rkt +++ b/beautiful-racket/br/demo/basic/parser.rkt @@ -1,62 +1,32 @@ #lang ragg -;; adapted from http://www.ittybittycomputers.com/IttyBitty/TinyBasic/TBuserMan.txt -;; MS Basic extensions -;; http://www.atariarchives.org/basicgames/showpage.php?page=i12 +basic-program : cr-line* [CR] -;; games -;; http://www.vintage-basic.net/games.html +cr-line : CR line [cr-line] -;; chipmunk basic -;; http://www.nicholson.com/rhn/basic/basic.man.html +line: INTEGER statement+ -basic-program : [CR] lines [CR] - -lines : INTEGER statements [CR | CR lines] - -statements : statement [":" statements] - -statement : "CLOSE" "#" INTEGER -| "END" +statement : "END" | "FOR" ID "=" expr "TO" expr ["STEP" expr] | "GOTO" expr | "IF" expr "THEN" (statement | expr) ; change: add expr -| "INPUT" id-list +| "INPUT" ID+ | ["LET"] ID "=" expr ; change: make "LET" opt -| "NEXT" id-list -| "PRINT" printlist -| "REM" STRING - -id-list : ID ["," id-list] - -value-list : value ["," value-list] - -constant-list : constant ["," constant-list] - -integer-list : INTEGER ["," integer-list] - -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] +| "NEXT" ID+ +| "PRINT" print-list +| REM-COMMENT -add-expr : mult-expr [("+" | "-") add-expr] +print-list : [expr [";" [print-list]*]] -mult-expr : negate-expr [("*" | "/") mult-expr] +expr : sum [("=" | "<>" | "><" | ">" | ">=" | "<" | "<=") expr] -negate-expr : ["-"] power-expr +sum : product [("+" | "-") sum]+ -power-expr : [power-expr "^"] value +product : value [("*" | "/") product]+ value : "(" expr ")" -| ID ["(" expr-list ")"] -| constant +| ID ["(" expr* ")"] +| INTEGER +| STRING +| REAL -constant : INTEGER | STRING | REAL diff --git a/beautiful-racket/br/demo/basic/parser0.rkt b/beautiful-racket/br/demo/basic/parser0.rkt new file mode 100644 index 0000000..d3beba8 --- /dev/null +++ b/beautiful-racket/br/demo/basic/parser0.rkt @@ -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 diff --git a/beautiful-racket/br/demo/basic/sinewave.bas b/beautiful-racket/br/demo/basic/sinewave.bas index f2f1c74..6070937 100644 --- a/beautiful-racket/br/demo/basic/sinewave.bas +++ b/beautiful-racket/br/demo/basic/sinewave.bas @@ -1,16 +1,3 @@ #lang br/demo/basic 10 PRINT TAB(30);"SINE WAVE" 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 \ No newline at end of file diff --git a/beautiful-racket/br/demo/basic/tokenizer.rkt b/beautiful-racket/br/demo/basic/tokenizer.rkt index c44b9b0..f22dc07 100644 --- a/beautiful-racket/br/demo/basic/tokenizer.rkt +++ b/beautiful-racket/br/demo/basic/tokenizer.rkt @@ -9,18 +9,26 @@ (define (next-token) (define get-token (lexer - [(repetition 1 +inf.0 "\n") (token 'CR '(CR))] - [(union "PRINT" "FOR" "TO" "STEP" "IF" "THEN" "GOTO" "REM" + [(:seq "REM" (repetition 1 +inf.0 (char-complement "\n"))) + (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" "CLEAR" "LIST" "RUN" "END") (string->symbol lexeme)] ;; this only matches integers [(repetition 1 +inf.0 numeric) (token 'INTEGER (string->number lexeme))] [(repetition 1 +inf.0 (union "." numeric)) (token 'REAL (string->number lexeme))] - [(union "," ";" ":" "+" "-" "*" "/" - "<=" ">=" "<>" "><" "<" ">" "=" "(" ")") lexeme] - [(:seq (repetition 1 +inf.0 upper-case)) (token 'ID lexeme)] - [upper-case (token 'UPPERCASE lexeme)] + ;; things that get thrown out: pass through as strings, + ;; because they can be matched literally in macros. + ;; things that become identifiers: pass through as symbols, + ;; 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)] [(:seq "\"" (complement (:: any-string "\"" any-string)) "\"") (token 'STRING (string-trim lexeme "\""))] [(eof) eof]))