From 12bc37145aa839c61ce66ed8eac52b4923d46bad Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 6 Feb 2017 17:30:54 -0800 Subject: [PATCH] handle negative numbers, for / next --- .../basic-demo-2/expander.rkt | 96 +++++-------------- beautiful-racket-demo/basic-demo-2/expr.rkt | 9 ++ beautiful-racket-demo/basic-demo-2/flow.rkt | 56 +++++++++++ beautiful-racket-demo/basic-demo-2/gosub.rkt | 3 - beautiful-racket-demo/basic-demo-2/lexer.rkt | 2 +- beautiful-racket-demo/basic-demo-2/line.rkt | 19 ++++ beautiful-racket-demo/basic-demo-2/misc.rkt | 7 ++ beautiful-racket-demo/basic-demo-2/parser.rkt | 11 ++- beautiful-racket-demo/basic-demo-2/run.rkt | 24 +++++ .../basic-demo-2/runtime.rkt | 3 + .../basic-demo-2/sample-for.rkt | 8 ++ .../basic-demo-2/sample-import.rkt | 3 + beautiful-racket-demo/basic-demo-2/sample.rkt | 9 ++ .../basic-demo-2/structs.rkt | 7 ++ 14 files changed, 180 insertions(+), 77 deletions(-) create mode 100644 beautiful-racket-demo/basic-demo-2/expr.rkt create mode 100644 beautiful-racket-demo/basic-demo-2/flow.rkt delete mode 100644 beautiful-racket-demo/basic-demo-2/gosub.rkt create mode 100644 beautiful-racket-demo/basic-demo-2/line.rkt create mode 100644 beautiful-racket-demo/basic-demo-2/misc.rkt create mode 100644 beautiful-racket-demo/basic-demo-2/run.rkt create mode 100644 beautiful-racket-demo/basic-demo-2/runtime.rkt create mode 100644 beautiful-racket-demo/basic-demo-2/sample-for.rkt create mode 100644 beautiful-racket-demo/basic-demo-2/sample-import.rkt create mode 100644 beautiful-racket-demo/basic-demo-2/sample.rkt create mode 100644 beautiful-racket-demo/basic-demo-2/structs.rkt diff --git a/beautiful-racket-demo/basic-demo-2/expander.rkt b/beautiful-racket-demo/basic-demo-2/expander.rkt index 499c5fc..e287769 100644 --- a/beautiful-racket-demo/basic-demo-2/expander.rkt +++ b/beautiful-racket-demo/basic-demo-2/expander.rkt @@ -1,39 +1,15 @@ #lang br/quicklang -(require (for-syntax racket/list sugar/debug)) -(provide (matching-identifiers-out #rx"^b-" (all-defined-out))) - -(struct line-error (msg)) - -(define (handle-line-error num le) - (error (format "error in line ~a: ~a" num (line-error-msg le)))) - -(define return-ks empty) - -(define (b-gosub num-expr) - (let/cc return-k - (push! return-ks return-k) - (b-goto num-expr))) - -(define (b-return) - (unless (pair? return-ks) - (raise (line-error "return without gosub"))) - (define top-return-k (pop! return-ks)) - (top-return-k)) - -(define-macro (b-line NUM STATEMENT ...) - (with-pattern ([LINE-NUM (prefix-id "line-" #'NUM - #:source #'NUM)]) - (syntax/loc caller-stx - (define (LINE-NUM) - (with-handlers ([line-error? (λ (le) (handle-line-error NUM le))]) - (void) STATEMENT ...))))) - -(define-for-syntax (find-unique-var-names stx) - (remove-duplicates - (for/list ([var-stx (in-list (syntax-flatten stx))] - #:when (syntax-property var-stx 'b-id)) - var-stx) - #:key syntax->datum)) +(require "runtime.rkt" + "run.rkt" + "line.rkt" + "expr.rkt" + "misc.rkt" + "flow.rkt") +(provide (rename-out [b-module-begin #%module-begin]) + (all-from-out "line.rkt" + "expr.rkt" + "misc.rkt" + "flow.rkt")) (define-macro (b-module-begin (b-program LINE ...)) (with-pattern @@ -41,45 +17,25 @@ [(LINE-FUNC ...) (prefix-id "line-" #'(NUM ...))] [(VAR-NAME ...) (find-unique-var-names #'(LINE ...))]) #'(#%module-begin + (module configure-runtime br + (require basic-demo-2/runtime) + (current-basic-port (current-output-port))) (define VAR-NAME 0) ... + (provide VAR-NAME ...) LINE ... (define line-table (apply hasheqv (append (list NUM LINE-FUNC) ...))) - (void (run line-table))))) -(provide (rename-out [b-module-begin #%module-begin])) - -(define-macro (b-let ID VAL) - #'(set! ID VAL)) - -(struct end-program-signal ()) -(struct change-line-signal (val)) + (void (parameterize ([current-output-port + (or (current-basic-port) (open-output-nowhere))]) + (run line-table)))))) -(define (b-end) (raise (end-program-signal))) -(define (b-goto num-expr) (raise (change-line-signal num-expr))) +(begin-for-syntax + (require racket/list) + (define (find-unique-var-names stx) + (remove-duplicates + (for/list ([var-stx (in-list (syntax-flatten stx))] + #:when (syntax-property var-stx 'b-id)) + var-stx) + #:key syntax->datum))) -(define (run line-table) - (define line-vec - (list->vector (sort (hash-keys line-table) <))) - (with-handlers ([end-program-signal? (λ (exn-val) (void))]) - (for/fold ([line-idx 0]) - ([i (in-naturals)] - #:break (>= line-idx (vector-length line-vec))) - (define line-num (vector-ref line-vec line-idx)) - (define line-func (hash-ref line-table line-num)) - (with-handlers - ([change-line-signal? - (λ (cls) - (define clsv (change-line-signal-val cls)) - (or - (and (exact-positive-integer? clsv) - (vector-member clsv line-vec)) - (error (format "error in line ~a: line ~a not found" - line-num clsv))))]) - (line-func) - (add1 line-idx))))) -(define (b-rem val) (void)) -(define (b-print [val ""]) (displayln val)) -(define (b-sum . nums) (apply + nums)) -(define (b-num-expr expr) - (if (integer? expr) (inexact->exact expr) expr)) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo-2/expr.rkt b/beautiful-racket-demo/basic-demo-2/expr.rkt new file mode 100644 index 0000000..6a9825e --- /dev/null +++ b/beautiful-racket-demo/basic-demo-2/expr.rkt @@ -0,0 +1,9 @@ +#lang br +(provide (matching-identifiers-out #rx"^b-" (all-defined-out))) + +(define (b-sum . nums) (apply + nums)) + +(define (b-num-expr expr) + (if (integer? expr) (inexact->exact expr) expr)) + +(define (b-negative num) (- num)) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo-2/flow.rkt b/beautiful-racket-demo/basic-demo-2/flow.rkt new file mode 100644 index 0000000..3e323a3 --- /dev/null +++ b/beautiful-racket-demo/basic-demo-2/flow.rkt @@ -0,0 +1,56 @@ +#lang br +(require "structs.rkt" "misc.rkt" "line.rkt") +(provide (matching-identifiers-out #rx"^b-" (all-defined-out))) + +(define (b-end) (raise (end-program-signal))) +(define (b-goto num-expr) (raise (change-line-signal num-expr))) + +(define gosub-ccs empty) + +(define (b-gosub num-expr) + (let/cc gosub-cc + (push! gosub-ccs gosub-cc) + (b-goto num-expr))) + +(define (b-return) + (unless (pair? gosub-ccs) + (raise (line-error "return without gosub"))) + (define top-return-k (pop! gosub-ccs)) + (top-return-k)) + +(define (in-closed-interval? x left right) + (define cmp (if (< left right) <= >=)) + (cmp left x right)) + +(define-macro-cases b-for + [(_ ID START END) #'(b-for ID START END 1)] + [(_ ID START END STEP) + #'(b-let ID (let/cc top-of-loop-cc + (push-thunk! + (cons 'ID + (λ () + (define next-val (+ ID STEP)) + (if (next-val . in-closed-interval? . START END) + (top-of-loop-cc next-val) + (remove-thunk! 'ID))))) + START))]) + +(define for-thunks (make-parameter empty)) + +(define (push-thunk! thunk) + (for-thunks (cons thunk (for-thunks)))) + +(define (remove-thunk! id-sym) + (for-thunks (remq (assq id-sym (for-thunks)) (for-thunks)))) + +(define-macro (b-next ID ...) #'(do-next 'ID ...)) + +(define (do-next [id-sym #f]) + (when (empty? (for-thunks)) + (raise-line-error "next without for")) + (define for-thunk + (cdr (if id-sym + (or (assq id-sym (for-thunks)) + (raise-line-error "next without for")) + (car (for-thunks))))) + (for-thunk)) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo-2/gosub.rkt b/beautiful-racket-demo/basic-demo-2/gosub.rkt deleted file mode 100644 index 795c0cd..0000000 --- a/beautiful-racket-demo/basic-demo-2/gosub.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang br -(provide b-gosub b-return) - diff --git a/beautiful-racket-demo/basic-demo-2/lexer.rkt b/beautiful-racket-demo/basic-demo-2/lexer.rkt index 67cebaa..bc13240 100644 --- a/beautiful-racket-demo/basic-demo-2/lexer.rkt +++ b/beautiful-racket-demo/basic-demo-2/lexer.rkt @@ -9,7 +9,7 @@ ["\n" (token 'NEWLINE lexeme)] [whitespace (token lexeme #:skip? #t)] [(from/stop-before "rem" "\n") (token 'REM lexeme)] - [(:or "print" "goto" "end" "+" ":" "gosub" "return" "let" "=") lexeme] + [(:or "print" "goto" "end" "+" ":" "gosub" "return" "let" "=" "-" "for" "to" "step" "next") lexeme] [(:seq (:+ alphabetic) (:* (:or alphabetic numeric))) (token 'ID (string->symbol lexeme))] [digits (token 'INTEGER (string->number lexeme))] [(:or (:seq (:? digits) "." digits) diff --git a/beautiful-racket-demo/basic-demo-2/line.rkt b/beautiful-racket-demo/basic-demo-2/line.rkt new file mode 100644 index 0000000..322b726 --- /dev/null +++ b/beautiful-racket-demo/basic-demo-2/line.rkt @@ -0,0 +1,19 @@ +#lang br +(require "structs.rkt") +(provide (all-defined-out)) + +(define-macro (b-line NUM STATEMENT ...) + (with-pattern ([LINE-NUM (prefix-id "line-" #'NUM + #:source #'NUM)]) + (syntax/loc caller-stx + (define (LINE-NUM) + (with-handlers ([line-error? (λ (le) (handle-line-error NUM le))]) + (void) STATEMENT ...))))) + +(define (handle-line-error num le) + (error (format "error in line ~a: ~a" num (line-error-msg le)))) + +(define (raise-line-error line-error-or-str) + (raise (if (string? line-error-or-str) + (line-error line-error-or-str) + line-error-or-str))) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo-2/misc.rkt b/beautiful-racket-demo/basic-demo-2/misc.rkt new file mode 100644 index 0000000..fea74d9 --- /dev/null +++ b/beautiful-racket-demo/basic-demo-2/misc.rkt @@ -0,0 +1,7 @@ +#lang br +(provide (matching-identifiers-out #rx"^b-" (all-defined-out))) + +(define (b-rem val) (void)) +(define (b-print [val ""]) (displayln val)) +(define-macro (b-let ID VAL) + #'(set! ID VAL)) diff --git a/beautiful-racket-demo/basic-demo-2/parser.rkt b/beautiful-racket-demo/basic-demo-2/parser.rkt index a0c128b..03c5dd8 100644 --- a/beautiful-racket-demo/basic-demo-2/parser.rkt +++ b/beautiful-racket-demo/basic-demo-2/parser.rkt @@ -2,7 +2,8 @@ b-program : [b-line] (/NEWLINE [b-line])* b-line : b-line-number [b-statement] (/":" [b-statement])* @b-line-number : INTEGER -@b-statement : b-rem | b-end | b-print | b-goto | b-gosub | b-return | b-let +@b-statement : b-rem | b-end | b-print | b-let + | b-goto | b-gosub | b-return | b-for | b-next b-rem : REM b-end : /"end" b-print : /"print" [STRING | b-num-expr] @@ -10,8 +11,12 @@ b-goto : /"goto" b-num-expr b-gosub : /"gosub" b-num-expr b-return : /"return" b-let : [/"let"] b-id /"=" b-num-expr +b-for : /"for" b-id /"=" b-num-expr /"to" b-num-expr [/"step" b-num-expr] +b-next : /"next" [b-id] @b-id : ID b-num-expr : b-sum -b-sum : b-value (/"+" b-value)* +b-sum : (b-value /"+" b-value)* @b-value : b-id | b-number -@b-number : INTEGER | DECIMAL \ No newline at end of file +@b-number : b-positive | b-negative +@b-positive : INTEGER | DECIMAL +b-negative : /"-" b-positive \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo-2/run.rkt b/beautiful-racket-demo/basic-demo-2/run.rkt new file mode 100644 index 0000000..fb942b9 --- /dev/null +++ b/beautiful-racket-demo/basic-demo-2/run.rkt @@ -0,0 +1,24 @@ +#lang br +(require "line.rkt" "structs.rkt") +(provide run) + +(define (run line-table) + (define line-vec + (list->vector (sort (hash-keys line-table) <))) + (with-handlers ([end-program-signal? (λ (exn-val) (void))]) + (for/fold ([line-idx 0]) + ([i (in-naturals)] + #:break (>= line-idx (vector-length line-vec))) + (define line-num (vector-ref line-vec line-idx)) + (define line-func (hash-ref line-table line-num)) + (with-handlers + ([change-line-signal? + (λ (cls) + (define clsv (change-line-signal-val cls)) + (or + (and (exact-positive-integer? clsv) + (vector-member clsv line-vec)) + (handle-line-error line-num + (line-error (format "line ~a not found" clsv)))))]) + (line-func) + (add1 line-idx))))) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo-2/runtime.rkt b/beautiful-racket-demo/basic-demo-2/runtime.rkt new file mode 100644 index 0000000..17e5656 --- /dev/null +++ b/beautiful-racket-demo/basic-demo-2/runtime.rkt @@ -0,0 +1,3 @@ +#lang br +(provide current-basic-port) +(define current-basic-port (make-parameter #f)) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo-2/sample-for.rkt b/beautiful-racket-demo/basic-demo-2/sample-for.rkt new file mode 100644 index 0000000..3346736 --- /dev/null +++ b/beautiful-racket-demo/basic-demo-2/sample-for.rkt @@ -0,0 +1,8 @@ +#lang basic-demo-2 +10 for a = 1 to 3 +20 print a +21 for b = 103 to 101 step -1 +22 print b +23 next b +30 next a +40 print "yay" \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo-2/sample-import.rkt b/beautiful-racket-demo/basic-demo-2/sample-import.rkt new file mode 100644 index 0000000..7004f51 --- /dev/null +++ b/beautiful-racket-demo/basic-demo-2/sample-import.rkt @@ -0,0 +1,3 @@ +#lang br +(require basic-demo-2/sample-var) +(* a a) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo-2/sample.rkt b/beautiful-racket-demo/basic-demo-2/sample.rkt new file mode 100644 index 0000000..a3089f6 --- /dev/null +++ b/beautiful-racket-demo/basic-demo-2/sample.rkt @@ -0,0 +1,9 @@ +#lang basic-demo +30 rem print 'ignored' +35 +50 print "never gets here" +40 end +60 print 'three' : print 1.0 + 3 +70 goto 11. + 18.5 + .5 +10 print "one" +20 print : goto 60.0 : end \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo-2/structs.rkt b/beautiful-racket-demo/basic-demo-2/structs.rkt new file mode 100644 index 0000000..3c7a7c2 --- /dev/null +++ b/beautiful-racket-demo/basic-demo-2/structs.rkt @@ -0,0 +1,7 @@ +#lang br +(provide (all-defined-out)) + +(struct end-program-signal ()) +(struct change-line-signal (val)) + +(struct line-error (msg)) \ No newline at end of file