diff --git a/beautiful-racket-demo/basic-demo/expander.rkt b/beautiful-racket-demo/basic-demo/expander.rkt index de03e0b..5449242 100644 --- a/beautiful-racket-demo/basic-demo/expander.rkt +++ b/beautiful-racket-demo/basic-demo/expander.rkt @@ -1,35 +1,22 @@ #lang br/quicklang -(provide (rename-out [b-module-begin #%module-begin]) - (matching-identifiers-out #rx"^b-" (all-defined-out))) +(provide (matching-identifiers-out #rx"^b-" (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) (void) STATEMENT ...)))) (define-macro (b-module-begin (b-program LINE ...)) (with-pattern - ([(LINE-NUM ...) - (filter-stx-prop 'b-line-number - (stx-flatten #'(LINE ...)))] - [(LINE-ID ...) (prefix-ids "line-" #'(LINE-NUM ...))]) + ([((NAME NUM STMT ...) ...) #'(LINE ...)] + [(LINE-FUNC ...) (prefix-id "line-" #'(NUM ...))]) #'(#%module-begin LINE ... (define line-table - (apply hasheqv (append (list LINE-NUM LINE-ID) ...))) + (apply hasheqv (append (list NUM LINE-FUNC) ...))) (run line-table)))) - -(define-macro (b-line LINE-NUMBER STATEMENT ...) - (with-pattern - ([LINE-NUMBER-ID (prefix-id "line-" #'LINE-NUMBER - #:source #'LINE-NUMBER)] - [ORIG-LOC caller-stx]) - (syntax/loc caller-stx - (define (LINE-NUMBER-ID #:srcloc? [loc #f]) - (if loc - (syntax-srcloc #'ORIG-LOC) - (begin (void) STATEMENT ...)))))) - -(define b-rem 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)) +(provide (rename-out [b-module-begin #%module-begin])) (struct $program-end-signal ()) (define (b-end) (raise ($program-end-signal))) @@ -37,8 +24,6 @@ (struct $change-line-signal (val)) (define (b-goto expr) (raise ($change-line-signal expr))) -(define-exn line-not-found exn:fail) - (define (run line-table) (define line-vec (list->vector (sort (hash-keys line-table) <))) @@ -55,7 +40,13 @@ (or (and (exact-positive-integer? clsv) (vector-member clsv line-vec)) - (raise-line-not-found - (line-proc #:srcloc? #t))))]) + (error (format "error in line ~a: line ~a not found" + line-num clsv))))]) (line-proc) (add1 line-idx))))) + +(define b-rem 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/expander0.rkt b/beautiful-racket-demo/basic-demo/expander0.rkt new file mode 100644 index 0000000..de03e0b --- /dev/null +++ b/beautiful-racket-demo/basic-demo/expander0.rkt @@ -0,0 +1,61 @@ +#lang br/quicklang +(provide (rename-out [b-module-begin #%module-begin]) + (matching-identifiers-out #rx"^b-" (all-defined-out))) + +(define-macro (b-module-begin (b-program LINE ...)) + (with-pattern + ([(LINE-NUM ...) + (filter-stx-prop 'b-line-number + (stx-flatten #'(LINE ...)))] + [(LINE-ID ...) (prefix-ids "line-" #'(LINE-NUM ...))]) + #'(#%module-begin + LINE ... + (define line-table + (apply hasheqv (append (list LINE-NUM LINE-ID) ...))) + (run line-table)))) + +(define-macro (b-line LINE-NUMBER STATEMENT ...) + (with-pattern + ([LINE-NUMBER-ID (prefix-id "line-" #'LINE-NUMBER + #:source #'LINE-NUMBER)] + [ORIG-LOC caller-stx]) + (syntax/loc caller-stx + (define (LINE-NUMBER-ID #:srcloc? [loc #f]) + (if loc + (syntax-srcloc #'ORIG-LOC) + (begin (void) STATEMENT ...)))))) + +(define b-rem 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)) + +(struct $program-end-signal ()) +(define (b-end) (raise ($program-end-signal))) + +(struct $change-line-signal (val)) +(define (b-goto expr) (raise ($change-line-signal expr))) + +(define-exn line-not-found exn:fail) + +(define (run line-table) + (define line-vec + (list->vector (sort (hash-keys line-table) <))) + (with-handlers ([$program-end-signal? void]) + (for/fold ([line-idx 0]) + ([i (in-naturals)]) + (unless (< line-idx (vector-length line-vec)) (b-end)) + (define line-num (vector-ref line-vec line-idx)) + (define line-proc (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)) + (raise-line-not-found + (line-proc #:srcloc? #t))))]) + (line-proc) + (add1 line-idx))))) diff --git a/beautiful-racket-demo/basic-demo/main.rkt b/beautiful-racket-demo/basic-demo/main.rkt index b18b5ba..805f6a6 100644 --- a/beautiful-racket-demo/basic-demo/main.rkt +++ b/beautiful-racket-demo/basic-demo/main.rkt @@ -1,10 +1,11 @@ #lang br/quicklang (require "parser.rkt" "tokenizer.rkt") -(module+ reader (provide read-syntax)) - (define (read-syntax path port) (define parse-tree (parse path (make-tokenizer port path))) (strip-bindings #`(module basic-mod basic-demo/expander - #,parse-tree))) \ No newline at end of file + #,parse-tree))) + +(module+ reader + (provide read-syntax)) diff --git a/beautiful-racket-demo/basic-demo/private/sample-pseudocode.rkt b/beautiful-racket-demo/basic-demo/private/sample-pseudocode.rkt new file mode 100644 index 0000000..cb306a5 --- /dev/null +++ b/beautiful-racket-demo/basic-demo/private/sample-pseudocode.rkt @@ -0,0 +1,8 @@ +(define (30) (rem print "'ignored'")) +(define (35) (void)) +(define (50) (print "never gets here")) +(define (40) (end)) +(define (60) (print "three") (print (+ 1.0 3))) +(define (70) (goto (+ 11 18.5 0.5))) +(define (10) (print "one")) +(define (20) (print) (goto 60) (end)) \ No newline at end of file