fix loop termination
This commit is contained in:
parent
e42afcd5df
commit
ff415bb42c
|
@ -39,18 +39,18 @@
|
||||||
(exn:line-not-found
|
(exn:line-not-found
|
||||||
(format "line number ~a not found in program" ln)
|
(format "line number ~a not found in program" ln)
|
||||||
(current-continuation-marks)))))
|
(current-continuation-marks)))))
|
||||||
(with-handlers ([exn:program-end? (λ _ (void))])
|
(for/fold ([program-counter 0])
|
||||||
(for/fold ([program-counter 0])
|
([i (in-naturals)]
|
||||||
([i (in-naturals)])
|
#:break (eq? program-counter 'end))
|
||||||
(cond
|
(cond
|
||||||
[(= program-counter (vector-length program-lines)) (basic:END)]
|
[(= program-counter (vector-length program-lines)) (basic:END)]
|
||||||
[else
|
[else
|
||||||
(match-define (cons line-number proc)
|
(define line-function (cdr (vector-ref program-lines program-counter)))
|
||||||
(vector-ref program-lines program-counter))
|
(define maybe-next-line (and line-function (line-function)))
|
||||||
(define maybe-jump-number (and proc (proc)))
|
(cond
|
||||||
(if (number? maybe-jump-number)
|
[(number? maybe-next-line) (line-number->index maybe-next-line)]
|
||||||
(line-number->index maybe-jump-number)
|
[(eq? 'end maybe-next-line) 'end]
|
||||||
(add1 program-counter))])))
|
[else (add1 program-counter)])]))
|
||||||
(void))
|
(void))
|
||||||
|
|
||||||
(define #'(cr-line _arg ...) #'(begin _arg ...))
|
(define #'(cr-line _arg ...) #'(begin _arg ...))
|
||||||
|
@ -115,7 +115,7 @@
|
||||||
(define-cases #'comp-expr
|
(define-cases #'comp-expr
|
||||||
[#'(_ _LEXPR "=" _REXPR) #'(comp-expr _LEXPR "equal?" _REXPR)] ; special case because = is overloaded
|
[#'(_ _LEXPR "=" _REXPR) #'(comp-expr _LEXPR "equal?" _REXPR)] ; special case because = is overloaded
|
||||||
[#'(_ _LEXPR _op _REXPR) (inject-syntax ([#'OP (string->symbol (syntax->datum #'_op))])
|
[#'(_ _LEXPR _op _REXPR) (inject-syntax ([#'OP (string->symbol (syntax->datum #'_op))])
|
||||||
#'(cond->int (OP _LEXPR _REXPR)))]
|
#'(cond->int (OP _LEXPR _REXPR)))]
|
||||||
[#'(_ _ARG) #'_ARG])
|
[#'(_ _ARG) #'_ARG])
|
||||||
(define <> (compose1 not equal?))
|
(define <> (compose1 not equal?))
|
||||||
|
|
||||||
|
@ -151,17 +151,12 @@
|
||||||
(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)])
|
||||||
(if num num str)))])
|
(if num num str)))])
|
||||||
|
|
||||||
(define (basic:GOTO where) where)
|
(define (basic:GOTO where) where)
|
||||||
|
|
||||||
(define (basic:RETURN) (car (current-return-stack)))
|
(define (basic:RETURN) (car (current-return-stack)))
|
||||||
|
|
||||||
|
|
||||||
(struct exn:program-end exn:fail ())
|
|
||||||
(define (basic:END)
|
(define (basic:END)
|
||||||
(raise
|
'end)
|
||||||
(exn:program-end
|
|
||||||
"program ended"
|
|
||||||
(current-continuation-marks))))
|
|
||||||
|
|
|
@ -1,87 +0,0 @@
|
||||||
#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,61 +0,0 @@
|
||||||
#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
|
|
Loading…
Reference in New Issue
Block a user