From 0ad719ce4a6ef6689a2fac3d8600d6abfe3a4e1c Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 30 May 2016 19:00:54 -0700 Subject: [PATCH] edit basic --- beautiful-racket/br/demo/basic/chemist.bas | 49 +++--- beautiful-racket/br/demo/basic/expander.rkt | 161 +++++++++--------- beautiful-racket/br/demo/basic/parser.rkt | 29 ++-- beautiful-racket/br/demo/basic/tokenizer.rkt | 13 +- beautiful-racket/br/demo/bf/bf-reader.rkt | 2 +- .../br/demo/hdl-tst/tokenizer.rkt | 2 +- beautiful-racket/br/demo/hdl/tokenizer.rkt | 2 +- 7 files changed, 130 insertions(+), 128 deletions(-) diff --git a/beautiful-racket/br/demo/basic/chemist.bas b/beautiful-racket/br/demo/basic/chemist.bas index 419b87f..38a5d53 100644 --- a/beautiful-racket/br/demo/basic/chemist.bas +++ b/beautiful-racket/br/demo/basic/chemist.bas @@ -1,29 +1,30 @@ #lang br/demo/basic -3 PRINT TAB(33);"CHEMIST" -6 PRINT TAB(15);"CREATIVE COMPUTING MORRISTOWN, NEW JERSEY" -8 PRINT:PRINT:PRINT -10 PRINT "THE FICTITIOUS CHECMICAL KRYPTOCYANIC ACID CAN ONLY BE" -20 PRINT "DILUTED BY THE RATIO OF 7 PARTS WATER TO 3 PARTS ACID." -30 PRINT "IF ANY OTHER RATIO IS ATTEMPTED, THE ACID BECOMES UNSTABLE" -40 PRINT "AND SOON EXPLODES. GIVEN THE AMOUNT OF ACID, YOU MUST" -50 PRINT "DECIDE WHO MUCH WATER TO ADD FOR DILUTION. IF YOU MISS" -60 PRINT "YOU FACE THE CONSEQUENCES." -100 A=INT(RND(1)*50) +3 print TAB(33);"Chemist" +6 print TAB(15);"Creative Computing | Morristown, New Jersey" +8 print:print:print +10 print "The fictitious chemical kryptocyanic acid can only be" +20 print "diluted by the ratio of 7 parts water to 3 parts acid." +30 print "if any other ratio is attempted, the acid becomes unstable" +40 print "and soon explodes. Given the amount of acid, you must" +50 print "decide who much water to add for dilution. If you miss," +60 print "you face the consequences." +100 A=INT(RND(50)) 110 W=7*A/3 -120 PRINT A;"LITERS OF KRYPTOCYANIC ACID. HOW MUCH WATER"; -130 INPUT R +115 if A=1 then P="liter" else P="liters" +120 print A; " "; P ; " of kryptocyanic acid. How much water?"; +130 input R 140 D=ABS(W-R) -150 IF D>W/20 THEN 200 -160 PRINT " GOOD JOB! YOU MAY BREATHE NOW, BUT DON'T INHALE THE FUMES!" -170 PRINT -180 GOTO 100 -200 PRINT " SIZZLE! YOU HAVE JUST BEEN DESALINATED INTO A BLOB" -210 PRINT " OF QUIVERING PROTOPLASM!" +150 if D>W/20 then 200 +160 print "Good job! You may breathe now, but don't inhale the fumes!" +170 print +180 goto 100 +200 print "Sizzle! You have just been desalinated into a blob" +210 print "of quivering protoplasm!" 220 T=T+1 -230 IF T=9 THEN 260 -240 PRINT " HOWEVER, YOU MAY TRY AGAIN WITH ANOTHER LIFE." -250 GOTO 100 -260 PRINT " YOUR 9 LIVES ARE USED, BUT YOU WILL BE LONG REMEMBERED FOR" -270 PRINT " YOUR CONTRIBUTIONS TO THE FIELD OF COMIC BOOK CHEMISTRY." -280 END \ No newline at end of file +230 if T=3 then 260 +240 print "However, you may try again with another life." +250 goto 100 +260 print "Your 3 lives are used, but you will be long remembered for" +270 print "your contributions to the field of comic-book chemistry." +280 end \ No newline at end of file diff --git a/beautiful-racket/br/demo/basic/expander.rkt b/beautiful-racket/br/demo/basic/expander.rkt index 7b2cb7d..157d9c5 100644 --- a/beautiful-racket/br/demo/basic/expander.rkt +++ b/beautiful-racket/br/demo/basic/expander.rkt @@ -3,18 +3,18 @@ (rename-out [basic-module-begin #%module-begin]) (rename-out [basic-top #%top]) (all-defined-out)) -(require br/stxparam (for-syntax br/datum)) +(require br/stxparam) ; BASIC implementation details ; http://www.atariarchives.org/basicgames/showpage.php?page=i12 (define-language-variables [A 0][B 0][C 0][D 0][E 0][F 0][G 0][H 0][I 0][J 0][K 0][L 0][M 0][N 0][O 0][P 0][Q 0][R 0][S 0][T 0][U 0][V 0][W 0][X 0][Y 0][Z 0][A$ ""][B$ ""][C$ ""][D$ ""][E$ ""][F$ ""][G$ ""][H$ ""][I$ ""][J$ ""][K$ ""][L$ ""][M$ ""][N$ ""][O$ ""][P$ ""][Q$ ""][R$ ""][S$ ""][T$ ""][U$ ""][V$ ""][W$ ""][X$ ""][Y$ ""][Z$ ""]) -(define-macro (basic-module-begin SRC-EXPR ...) +(define-macro (basic-module-begin . PROGRAM-LINES) #'(#%module-begin (inject-language-variables (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z A$ B$ C$ D$ E$ F$ G$ H$ I$ J$ K$ L$ M$ N$ O$ P$ Q$ R$ S$ T$ U$ V$ W$ X$ Y$ Z$) - (println (quote SRC-EXPR ...)) - SRC-EXPR ...))) + (println (quote . PROGRAM-LINES)) + . PROGRAM-LINES))) ; #%app and #%datum have to be present to make #%top work (define-macro (basic-top . ID) @@ -22,71 +22,71 @@ (displayln (format "got unbound identifier: ~a" 'ID)) (procedure-rename (λ xs (cons 'ID xs)) (string->symbol (format "undefined:~a" 'ID))))) -(define-macro (program LINE ...) #'(run (list LINE ...))) - +(define-macro (basic-program LINE ...) #'(run (list LINE ...))) (struct exn:line-not-found exn:fail ()) -(struct exn:program-end 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 exn:program-end exn:fail ()) +(define (raise-program-end-error) + (raise (exn:program-end "" (current-continuation-marks)))) -(define (run lines) - (define program-lines (list->vector (filter (λ(ln) (not (equal? ln "cr"))) lines))) - (define (line-number->index ln) +(define (run line-list) + (define lines (list->vector line-list)) + (define (find-index ln) (or - (for/or ([idx (in-range (vector-length program-lines))]) - (and (= (car (vector-ref program-lines idx)) ln) + (for/or ([idx (in-range (vector-length lines))]) + (and (= ($line-number (vector-ref lines idx)) ln) idx)) - (raise - (exn:line-not-found - (format "line number ~a not found in program" ln) - (current-continuation-marks))))) - (with-handlers ([exn:program-end? (λ(exn) (void))]) - (void + (raise-line-not-found-error ln))) + (void + (with-handlers ([exn:program-end? void]) (for/fold ([program-counter 0]) ([i (in-naturals)]) - (cond - [(= program-counter (vector-length program-lines)) (basic:END)] - [else - (define line-function (cdr (vector-ref program-lines program-counter))) - (define maybe-next-line (and line-function (line-function))) - (cond - [(number? maybe-next-line) (line-number->index maybe-next-line)] - [else (add1 program-counter)])]))))) - -(define-macro (cr-line ARG ...) #'(begin ARG ...)) - - -(define current-return-stack (make-parameter empty)) - + (if (= program-counter (vector-length lines)) + (basic:end) + (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 return-stack empty) + +(define (do-gosub number where) + (if (or (empty? return-stack) + (not (= number (car return-stack)))) + (begin + (set! return-stack (cons number return-stack)) + (basic:goto where)) + (set! return-stack (cdr return-stack)))) + +(struct $line (number thunk) #:transparent) (define-macro line - [(_ NUMBER (statement-list (statement "GOSUB" WHERE))) - #'(cons NUMBER - (λ _ - (let ([return-stack (current-return-stack)]) - (cond - [(or (empty? return-stack) - (not (= NUMBER (car return-stack)))) - (current-return-stack (cons NUMBER (current-return-stack))) - (basic:GOTO WHERE)] - [else (current-return-stack (cdr (current-return-stack)))]))))] - [(_ NUMBER STATEMENT ...) #'(cons NUMBER (λ _ STATEMENT ...))]) - + [(_ NUMBER (statement "gosub" WHERE)) + #'($line NUMBER (λ () (do-gosub NUMBER WHERE)))] + [(_ NUMBER . STATEMENTS) + #'($line NUMBER (λ () . STATEMENTS))]) (define-macro statement [(statement ID "=" EXPR) #'(set! ID EXPR)] - [(statement PROC-STRING ARG ...) + [(statement PROC-NAME . ARGS) (with-pattern - ([PROC-ID (prefix-id "basic:" #'PROC-STRING)]) - #'(PROC-ID ARG ...))]) - -(define-macro basic:IF - [(_ COND "THEN" TRUE-RESULT "ELSE" FALSE-RESULT) - #'(if (true? COND) - TRUE-RESULT - FALSE-RESULT)] - [(_ COND "THEN" TRUE-RESULT) + ([PROC-ID (prefix-id "basic:" #'PROC-NAME)]) + #'(PROC-ID . ARGS))]) + +(define-macro basic:if + [(_ COND-EXPR TRUE-EXPR FALSE-EXPR) + #'(if (true? COND-EXPR) + TRUE-EXPR + FALSE-EXPR)] + [(_ COND TRUE-EXPR) #'(when (true? COND) - TRUE-RESULT)]) + TRUE-EXPR)]) (define true? (compose1 not zero?)) (define (cond->int cond) (if cond 1 0)) @@ -94,35 +94,38 @@ (define (basic:or . args) (cond->int (ormap true? args))) (define-macro expr + [(_ COMP-EXPR) #'COMP-EXPR] [(_ COMP-EXPR "AND" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)] - [(_ COMP-EXPR "OR" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)] - [(_ COMP-EXPR) #'COMP-EXPR]) + [(_ COMP-EXPR "OR" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)]) (define-macro comp-expr - [(_ LEXPR "=" REXPR) #'(comp-expr LEXPR "equal?" REXPR)] ; special case because = is overloaded - [(_ LEXPR OP-STR REXPR) (with-pattern ([OP (replace-context #'here (prefix-id #'OP-STR))]) - #'(cond->int (OP LEXPR REXPR)))] - [(_ ARG) #'ARG]) + [(_ 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 sum - [(_ TERM "+" SUM) #'(+ TERM SUM)] - [(_ TERM "-" SUM) #'(- TERM SUM)] - [(_ TERM) #'TERM]) + [(_ SUM) #'SUM] + [(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)] + [(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)]) (define-macro product - [(_ VALUE "*" PRODUCT) #'(* VALUE PRODUCT)] - [(_ VALUE "/" PRODUCT) #'(/ VALUE PRODUCT)] - [(_ VALUE) #'VALUE]) + [(_ VALUE) #'VALUE] + [(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)] + [(_ PRODUCT "/" VALUE) #'(/ PRODUCT VALUE)]) (define print-list list) -(define (basic:PRINT args) +(define (basic:print [args #f]) (match args - [(list) (displayln "")] + [#f (displayln "")] [(list print-list-item ... ";" pl) (begin (for-each display print-list-item) - (basic:PRINT pl))] + (basic:print pl))] [(list print-list-item ... ";") (for-each display print-list-item)] [(list print-list-item ...) (for-each displayln print-list-item)])) @@ -132,21 +135,17 @@ (define (ABS num) (inexact->exact (abs num))) (define (RND num) (* (random) num)) -(define-macro basic:INPUT - [(_ PRINT-LIST ";" _ID) +(define-macro basic:input + [(_ PRINT-LIST _ID) #'(begin - (basic:PRINT (append PRINT-LIST (list ";"))) - (basic:INPUT _ID))] + (basic:print (append PRINT-LIST (list ";"))) + (basic:input _ID))] [(_ ID) #'(set! ID (let* ([str (read-line)] [num (string->number str)]) (or num str)))]) -(define (basic:GOTO where) where) +(define (basic:goto where) where) -(define (basic:RETURN) (car (current-return-stack))) +(define (basic:return) (car return-stack)) -(define (basic:END) - (raise - (exn:program-end - "" - (current-continuation-marks)))) +(define (basic:end) (raise-program-end-error)) diff --git a/beautiful-racket/br/demo/basic/parser.rkt b/beautiful-racket/br/demo/basic/parser.rkt index 00ef33d..18d2695 100644 --- a/beautiful-racket/br/demo/basic/parser.rkt +++ b/beautiful-racket/br/demo/basic/parser.rkt @@ -1,29 +1,30 @@ #lang brag -program : line* +basic-program : line* -line: NUMBER statement [":" statement]* +line: NUMBER statement [/":" statement]* -statement : "END" -| "GOSUB" NUMBER -| "GOTO" expr -| "IF" expr "THEN" (statement | expr) ["ELSE" (statement | expr)] -| "INPUT" [print-list ";"] ID -| ID "=" expr ; change: make "LET" opt -| "PRINT" print-list -| "RETURN" +statement : "end" +| "gosub" expr +| "goto" expr +| "if" expr /"then" (statement | expr) [/"else" (statement | expr)] +| "input" [print-list /";"] ID +| ID "=" expr +| "print" [print-list] +| "return" -print-list : [expr [";" [print-list]]] +print-list : expr [";" [print-list]] expr : comp-expr [("AND" | "OR") expr] comp-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") comp-expr] -sum : product [("+" | "-") sum] +sum : [sum ("+" | "-")] product -product : value [("*" | "/") product] +product : [product ("*" | "/")] value -@value : ID | id-expr +@value : ID +| id-expr | /"(" expr /")" | STRING | NUMBER diff --git a/beautiful-racket/br/demo/basic/tokenizer.rkt b/beautiful-racket/br/demo/basic/tokenizer.rkt index e239317..46ff2bd 100644 --- a/beautiful-racket/br/demo/basic/tokenizer.rkt +++ b/beautiful-racket/br/demo/basic/tokenizer.rkt @@ -13,16 +13,17 @@ (define (tokenize input-port) (define (next-token) (define get-token - (lexer + (lexer-src-pos [(eof) eof] [(union #\tab #\space #\newline (seq number " REM" (repetition 1 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)] - [(union "PRINT" "FOR" "TO" "STEP" "IF" "GOTO" - "INPUT" "LET" "NEXT" "RETURN" - "CLEAR" "LIST" "RUN" "END" - "THEN" "ELSE" "GOSUB" "AND" "OR" + [(union "PRINT" "print" "FOR" "for" "TO" "to" "STEP" "step" "IF" "if" + "GOTO" "goto" "INPUT" "input" "LET" "let" "NEXT" "next" + "RETURN" "return" "CLEAR" "clear" "LIST" "list" "RUN" "run" + "END" "end" "THEN" "then" "ELSE" "else" "GOSUB" "gosub" + "AND" "and" "OR" "or" ";" "=" "(" ")" "+" "-" "*" "/" - "<=" ">=" "<>" "<" ">" "=" ":") lexeme] + "<=" ">=" "<>" "<" ">" "=" ":") (string-downcase lexeme)] [(union ",") (get-token input-port)] [number (token 'NUMBER (string->number lexeme))] [(seq (repetition 1 +inf.0 upper-case) (? "$")) (token 'ID (string->symbol lexeme))] diff --git a/beautiful-racket/br/demo/bf/bf-reader.rkt b/beautiful-racket/br/demo/bf/bf-reader.rkt index 94ad072..a38b7e1 100644 --- a/beautiful-racket/br/demo/bf/bf-reader.rkt +++ b/beautiful-racket/br/demo/bf/bf-reader.rkt @@ -3,7 +3,7 @@ (define (tokenize input-port) (define (next-token) (define get-token - (lexer + (lexer-src-pos [(char-set "><-.,+[]") lexeme] [(char-complement (char-set "><-.,+[]")) (token 'OTHER #:skip? #t)] diff --git a/beautiful-racket/br/demo/hdl-tst/tokenizer.rkt b/beautiful-racket/br/demo/hdl-tst/tokenizer.rkt index d4b0a32..a5255ce 100644 --- a/beautiful-racket/br/demo/hdl-tst/tokenizer.rkt +++ b/beautiful-racket/br/demo/hdl-tst/tokenizer.rkt @@ -7,7 +7,7 @@ (define (tokenize input-port) (define (next-token) (define get-token - (lexer + (lexer-src-pos [(eof) eof] [(union (seq "/*" (complement (seq any-string "*/" any-string)) "*/") diff --git a/beautiful-racket/br/demo/hdl/tokenizer.rkt b/beautiful-racket/br/demo/hdl/tokenizer.rkt index 6becdec..0ba1cef 100644 --- a/beautiful-racket/br/demo/hdl/tokenizer.rkt +++ b/beautiful-racket/br/demo/hdl/tokenizer.rkt @@ -7,7 +7,7 @@ (define (tokenize input-port) (define (next-token) (define get-token - (lexer + (lexer-src-pos [(eof) eof] [(union (seq "/*" (complement (seq any-string "*/" any-string)) "*/")