edit basic

pull/2/head
Matthew Butterick 9 years ago
parent aed79823ea
commit 0ad719ce4a

@ -1,29 +1,30 @@
#lang br/demo/basic #lang br/demo/basic
3 PRINT TAB(33);"CHEMIST" 3 print TAB(33);"Chemist"
6 PRINT TAB(15);"CREATIVE COMPUTING MORRISTOWN, NEW JERSEY" 6 print TAB(15);"Creative Computing | Morristown, New Jersey"
8 PRINT:PRINT:PRINT 8 print:print:print
10 PRINT "THE FICTITIOUS CHECMICAL KRYPTOCYANIC ACID CAN ONLY BE" 10 print "The fictitious chemical kryptocyanic acid can only be"
20 PRINT "DILUTED BY THE RATIO OF 7 PARTS WATER TO 3 PARTS ACID." 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" 30 print "if any other ratio is attempted, the acid becomes unstable"
40 PRINT "AND SOON EXPLODES. GIVEN THE AMOUNT OF ACID, YOU MUST" 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" 50 print "decide who much water to add for dilution. If you miss,"
60 PRINT "YOU FACE THE CONSEQUENCES." 60 print "you face the consequences."
100 A=INT(RND(1)*50) 100 A=INT(RND(50))
110 W=7*A/3 110 W=7*A/3
120 PRINT A;"LITERS OF KRYPTOCYANIC ACID. HOW MUCH WATER"; 115 if A=1 then P="liter" else P="liters"
130 INPUT R 120 print A; " "; P ; " of kryptocyanic acid. How much water?";
130 input R
140 D=ABS(W-R) 140 D=ABS(W-R)
150 IF D>W/20 THEN 200 150 if D>W/20 then 200
160 PRINT " GOOD JOB! YOU MAY BREATHE NOW, BUT DON'T INHALE THE FUMES!" 160 print "Good job! You may breathe now, but don't inhale the fumes!"
170 PRINT 170 print
180 GOTO 100 180 goto 100
200 PRINT " SIZZLE! YOU HAVE JUST BEEN DESALINATED INTO A BLOB" 200 print "Sizzle! You have just been desalinated into a blob"
210 PRINT " OF QUIVERING PROTOPLASM!" 210 print "of quivering protoplasm!"
220 T=T+1 220 T=T+1
230 IF T=9 THEN 260 230 if T=3 then 260
240 PRINT " HOWEVER, YOU MAY TRY AGAIN WITH ANOTHER LIFE." 240 print "However, you may try again with another life."
250 GOTO 100 250 goto 100
260 PRINT " YOUR 9 LIVES ARE USED, BUT YOU WILL BE LONG REMEMBERED FOR" 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." 270 print "your contributions to the field of comic-book chemistry."
280 END 280 end

@ -3,18 +3,18 @@
(rename-out [basic-module-begin #%module-begin]) (rename-out [basic-module-begin #%module-begin])
(rename-out [basic-top #%top]) (rename-out [basic-top #%top])
(all-defined-out)) (all-defined-out))
(require br/stxparam (for-syntax br/datum)) (require br/stxparam)
; BASIC implementation details ; BASIC implementation details
; http://www.atariarchives.org/basicgames/showpage.php?page=i12 ; 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-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 #'(#%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$) (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 ...)) (println (quote . PROGRAM-LINES))
SRC-EXPR ...))) . PROGRAM-LINES)))
; #%app and #%datum have to be present to make #%top work ; #%app and #%datum have to be present to make #%top work
(define-macro (basic-top . ID) (define-macro (basic-top . ID)
@ -22,71 +22,71 @@
(displayln (format "got unbound identifier: ~a" 'ID)) (displayln (format "got unbound identifier: ~a" 'ID))
(procedure-rename (λ xs (cons 'ID xs)) (string->symbol (format "undefined:~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: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 (run line-list)
(define program-lines (list->vector (filter (λ(ln) (not (equal? ln "cr"))) lines))) (define lines (list->vector line-list))
(define (line-number->index ln) (define (find-index ln)
(or (or
(for/or ([idx (in-range (vector-length program-lines))]) (for/or ([idx (in-range (vector-length lines))])
(and (= (car (vector-ref program-lines idx)) ln) (and (= ($line-number (vector-ref lines idx)) ln)
idx)) idx))
(raise (raise-line-not-found-error ln)))
(exn:line-not-found
(format "line number ~a not found in program" ln)
(current-continuation-marks)))))
(with-handlers ([exn:program-end? (λ(exn) (void))])
(void (void
(with-handlers ([exn:program-end? void])
(for/fold ([program-counter 0]) (for/fold ([program-counter 0])
([i (in-naturals)]) ([i (in-naturals)])
(cond (if (= program-counter (vector-length lines))
[(= program-counter (vector-length program-lines)) (basic:END)] (basic:end)
[else (let* ([line-thunk ($line-thunk (vector-ref lines program-counter))]
(define line-function (cdr (vector-ref program-lines program-counter))) [maybe-line-number (line-thunk)])
(define maybe-next-line (and line-function (line-function))) (if (number? maybe-line-number)
(cond (find-index maybe-line-number)
[(number? maybe-next-line) (line-number->index maybe-next-line)] (add1 program-counter))))))))
[else (add1 program-counter)])])))))
(define return-stack empty)
(define-macro (cr-line ARG ...) #'(begin ARG ...))
(define (do-gosub number where)
(if (or (empty? return-stack)
(define current-return-stack (make-parameter empty)) (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 (define-macro line
[(_ NUMBER (statement-list (statement "GOSUB" WHERE))) [(_ NUMBER (statement "gosub" WHERE))
#'(cons NUMBER #'($line NUMBER (λ () (do-gosub NUMBER WHERE)))]
(λ _ [(_ NUMBER . STATEMENTS)
(let ([return-stack (current-return-stack)]) #'($line NUMBER (λ () . STATEMENTS))])
(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 ...))])
(define-macro statement (define-macro statement
[(statement ID "=" EXPR) #'(set! ID EXPR)] [(statement ID "=" EXPR) #'(set! ID EXPR)]
[(statement PROC-STRING ARG ...) [(statement PROC-NAME . ARGS)
(with-pattern (with-pattern
([PROC-ID (prefix-id "basic:" #'PROC-STRING)]) ([PROC-ID (prefix-id "basic:" #'PROC-NAME)])
#'(PROC-ID ARG ...))]) #'(PROC-ID . ARGS))])
(define-macro basic:IF (define-macro basic:if
[(_ COND "THEN" TRUE-RESULT "ELSE" FALSE-RESULT) [(_ COND-EXPR TRUE-EXPR FALSE-EXPR)
#'(if (true? COND) #'(if (true? COND-EXPR)
TRUE-RESULT TRUE-EXPR
FALSE-RESULT)] FALSE-EXPR)]
[(_ COND "THEN" TRUE-RESULT) [(_ COND TRUE-EXPR)
#'(when (true? COND) #'(when (true? COND)
TRUE-RESULT)]) TRUE-EXPR)])
(define true? (compose1 not zero?)) (define true? (compose1 not zero?))
(define (cond->int cond) (if cond 1 0)) (define (cond->int cond) (if cond 1 0))
@ -94,35 +94,38 @@
(define (basic:or . args) (cond->int (ormap true? args))) (define (basic:or . args) (cond->int (ormap true? args)))
(define-macro expr (define-macro expr
[(_ COMP-EXPR) #'COMP-EXPR]
[(_ COMP-EXPR "AND" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)] [(_ COMP-EXPR "AND" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)]
[(_ COMP-EXPR "OR" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)] [(_ COMP-EXPR "OR" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)])
[(_ COMP-EXPR) #'COMP-EXPR])
(define-macro comp-expr (define-macro comp-expr
[(_ LEXPR "=" REXPR) #'(comp-expr LEXPR "equal?" REXPR)] ; special case because = is overloaded [(_ SUM) #'SUM]
[(_ LEXPR OP-STR REXPR) (with-pattern ([OP (replace-context #'here (prefix-id #'OP-STR))]) [(_ SUM "=" COMP-EXPR)
#'(cond->int (OP LEXPR REXPR)))] #'(cond->int (equal? SUM COMP-EXPR))] ; special case because `=` is overloaded in basic
[(_ ARG) #'ARG]) [(_ 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 <> (compose1 not equal?))
(define-macro sum (define-macro sum
[(_ TERM "+" SUM) #'(+ TERM SUM)] [(_ SUM) #'SUM]
[(_ TERM "-" SUM) #'(- TERM SUM)] [(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)]
[(_ TERM) #'TERM]) [(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)])
(define-macro product (define-macro product
[(_ VALUE "*" PRODUCT) #'(* VALUE PRODUCT)] [(_ VALUE) #'VALUE]
[(_ VALUE "/" PRODUCT) #'(/ VALUE PRODUCT)] [(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)]
[(_ VALUE) #'VALUE]) [(_ PRODUCT "/" VALUE) #'(/ PRODUCT VALUE)])
(define print-list list) (define print-list list)
(define (basic:PRINT args) (define (basic:print [args #f])
(match args (match args
[(list) (displayln "")] [#f (displayln "")]
[(list print-list-item ... ";" pl) (begin (for-each display print-list-item) [(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 display print-list-item)]
[(list print-list-item ...) (for-each displayln 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 (ABS num) (inexact->exact (abs num)))
(define (RND num) (* (random) num)) (define (RND num) (* (random) num))
(define-macro basic:INPUT (define-macro basic:input
[(_ PRINT-LIST ";" _ID) [(_ PRINT-LIST _ID)
#'(begin #'(begin
(basic:PRINT (append PRINT-LIST (list ";"))) (basic:print (append PRINT-LIST (list ";")))
(basic:INPUT _ID))] (basic:input _ID))]
[(_ ID) #'(set! ID (let* ([str (read-line)] [(_ ID) #'(set! ID (let* ([str (read-line)]
[num (string->number str)]) [num (string->number str)])
(or num 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) (define (basic:end) (raise-program-end-error))
(raise
(exn:program-end
""
(current-continuation-marks))))

@ -1,29 +1,30 @@
#lang brag #lang brag
program : line* basic-program : line*
line: NUMBER statement [":" statement]* line: NUMBER statement [/":" statement]*
statement : "END" statement : "end"
| "GOSUB" NUMBER | "gosub" expr
| "GOTO" expr | "goto" expr
| "IF" expr "THEN" (statement | expr) ["ELSE" (statement | expr)] | "if" expr /"then" (statement | expr) [/"else" (statement | expr)]
| "INPUT" [print-list ";"] ID | "input" [print-list /";"] ID
| ID "=" expr ; change: make "LET" opt | ID "=" expr
| "PRINT" print-list | "print" [print-list]
| "RETURN" | "return"
print-list : [expr [";" [print-list]]] print-list : expr [";" [print-list]]
expr : comp-expr [("AND" | "OR") expr] expr : comp-expr [("AND" | "OR") expr]
comp-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") comp-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 /")" | /"(" expr /")"
| STRING | STRING
| NUMBER | NUMBER

@ -13,16 +13,17 @@
(define (tokenize input-port) (define (tokenize input-port)
(define (next-token) (define (next-token)
(define get-token (define get-token
(lexer (lexer-src-pos
[(eof) eof] [(eof) eof]
[(union #\tab #\space #\newline [(union #\tab #\space #\newline
(seq number " REM" (repetition 1 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)] (seq number " REM" (repetition 1 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)]
[(union "PRINT" "FOR" "TO" "STEP" "IF" "GOTO" [(union "PRINT" "print" "FOR" "for" "TO" "to" "STEP" "step" "IF" "if"
"INPUT" "LET" "NEXT" "RETURN" "GOTO" "goto" "INPUT" "input" "LET" "let" "NEXT" "next"
"CLEAR" "LIST" "RUN" "END" "RETURN" "return" "CLEAR" "clear" "LIST" "list" "RUN" "run"
"THEN" "ELSE" "GOSUB" "AND" "OR" "END" "end" "THEN" "then" "ELSE" "else" "GOSUB" "gosub"
"AND" "and" "OR" "or"
";" "=" "(" ")" "+" "-" "*" "/" ";" "=" "(" ")" "+" "-" "*" "/"
"<=" ">=" "<>" "<" ">" "=" ":") lexeme] "<=" ">=" "<>" "<" ">" "=" ":") (string-downcase lexeme)]
[(union ",") (get-token input-port)] [(union ",") (get-token input-port)]
[number (token 'NUMBER (string->number lexeme))] [number (token 'NUMBER (string->number lexeme))]
[(seq (repetition 1 +inf.0 upper-case) (? "$")) (token 'ID (string->symbol lexeme))] [(seq (repetition 1 +inf.0 upper-case) (? "$")) (token 'ID (string->symbol lexeme))]

@ -3,7 +3,7 @@
(define (tokenize input-port) (define (tokenize input-port)
(define (next-token) (define (next-token)
(define get-token (define get-token
(lexer (lexer-src-pos
[(char-set "><-.,+[]") lexeme] [(char-set "><-.,+[]") lexeme]
[(char-complement (char-set "><-.,+[]")) [(char-complement (char-set "><-.,+[]"))
(token 'OTHER #:skip? #t)] (token 'OTHER #:skip? #t)]

@ -7,7 +7,7 @@
(define (tokenize input-port) (define (tokenize input-port)
(define (next-token) (define (next-token)
(define get-token (define get-token
(lexer (lexer-src-pos
[(eof) eof] [(eof) eof]
[(union [(union
(seq "/*" (complement (seq any-string "*/" any-string)) "*/") (seq "/*" (complement (seq any-string "*/" any-string)) "*/")

@ -7,7 +7,7 @@
(define (tokenize input-port) (define (tokenize input-port)
(define (next-token) (define (next-token)
(define get-token (define get-token
(lexer (lexer-src-pos
[(eof) eof] [(eof) eof]
[(union [(union
(seq "/*" (complement (seq any-string "*/" any-string)) "*/") (seq "/*" (complement (seq any-string "*/" any-string)) "*/")

Loading…
Cancel
Save