fix loop termination

beautiful-racket/br/demo/basic/expander.rkt

@@ -39,18 +39,18 @@
       (exn:line-not-found
        (format "line number ~a not found in program" ln)
        (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))
 
 (define #'(cr-line _arg ...) #'(begin _arg ...))
@@ -115,7 +115,7 @@
 (define-cases #'comp-expr
   [#'(_ _LEXPR "=" _REXPR) #'(comp-expr _LEXPR "equal?" _REXPR)] ; special case because = is overloaded
   [#'(_ _LEXPR _op _REXPR) (inject-syntax ([#'OP (string->symbol (syntax->datum #'_op))])
-                                       #'(cond->int (OP _LEXPR _REXPR)))]
+                                          #'(cond->int (OP _LEXPR _REXPR)))]
   [#'(_ _ARG) #'_ARG])
 (define <> (compose1 not equal?))
 
@@ -151,17 +151,12 @@
        (basic:PRINT (append _PRINT-LIST (list ";")))
        (basic:INPUT _ID))]
   [#'(_ _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:RETURN) (car (current-return-stack)))
 
-
-(struct exn:program-end exn:fail ())
 (define (basic:END)
-  (raise
+  'end)
-   (exn:program-end
-    "program ended"
-    (current-continuation-marks))))

beautiful-racket/br/demo/basic/expander0.rkt

@@ -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 ...)])
-

beautiful-racket/br/demo/basic/parser0.rkt

@@ -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