From 15675c7558331b1a29e65993128daf3294164ec0 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 24 Jan 2017 18:12:12 -0800 Subject: [PATCH] boom --- .../{basic-demo => basic-demo-nth}/3dplot.bas | 0 .../aceyducey.bas | 0 .../amazing.bas | 0 .../basic-demo-nth/basic-test.rkt | 4 + .../{basic-demo => basic-demo-nth}/bounce.bas | 0 .../{basic-demo => basic-demo-nth}/change.bas | 0 .../chemist.bas | 0 .../basic-demo-nth/colorer.rkt | 51 +++ .../{basic-demo => basic-demo-nth}/dim.bas | 0 .../basic-demo-nth/expander.rkt | 260 +++++++++++++++ .../{basic-demo => basic-demo-nth}/for.bas | 0 .../{basic-demo => basic-demo-nth}/gosub.bas | 0 .../importest.rkt | 0 beautiful-racket-demo/basic-demo-nth/main.rkt | 26 ++ .../next-fix.bas | 0 .../{basic-demo => basic-demo-nth}/on.bas | 0 .../basic-demo-nth/parser.rkt | 42 +++ .../sinewave.bas | 0 .../{basic-demo => basic-demo-nth}/tabs.bas | 0 .../basic-demo-nth/tokenizer.rkt | 68 ++++ .../basic-demo/basic-test.rkt | 7 + beautiful-racket-demo/basic-demo/colorer.rkt | 47 +-- beautiful-racket-demo/basic-demo/expander.rkt | 301 +++--------------- beautiful-racket-demo/basic-demo/importer.rkt | 2 + beautiful-racket-demo/basic-demo/main.rkt | 14 +- beautiful-racket-demo/basic-demo/parser.rkt | 44 +-- beautiful-racket-demo/basic-demo/runtime.rkt | 3 + .../basic-demo/test-parser.rkt | 11 + .../basic-demo/tokenizer.rkt | 82 ++--- beautiful-racket-lib/br/exception.rkt | 28 ++ beautiful-racket-lib/br/main.rkt | 4 +- beautiful-racket-lib/br/syntax.rkt | 9 +- 32 files changed, 634 insertions(+), 369 deletions(-) rename beautiful-racket-demo/{basic-demo => basic-demo-nth}/3dplot.bas (100%) rename beautiful-racket-demo/{basic-demo => basic-demo-nth}/aceyducey.bas (100%) rename beautiful-racket-demo/{basic-demo => basic-demo-nth}/amazing.bas (100%) create mode 100644 beautiful-racket-demo/basic-demo-nth/basic-test.rkt rename beautiful-racket-demo/{basic-demo => basic-demo-nth}/bounce.bas (100%) rename beautiful-racket-demo/{basic-demo => basic-demo-nth}/change.bas (100%) rename beautiful-racket-demo/{basic-demo => basic-demo-nth}/chemist.bas (100%) create mode 100644 beautiful-racket-demo/basic-demo-nth/colorer.rkt rename beautiful-racket-demo/{basic-demo => basic-demo-nth}/dim.bas (100%) create mode 100644 beautiful-racket-demo/basic-demo-nth/expander.rkt rename beautiful-racket-demo/{basic-demo => basic-demo-nth}/for.bas (100%) rename beautiful-racket-demo/{basic-demo => basic-demo-nth}/gosub.bas (100%) rename beautiful-racket-demo/{basic-demo => basic-demo-nth}/importest.rkt (100%) create mode 100644 beautiful-racket-demo/basic-demo-nth/main.rkt rename beautiful-racket-demo/{basic-demo => basic-demo-nth}/next-fix.bas (100%) rename beautiful-racket-demo/{basic-demo => basic-demo-nth}/on.bas (100%) create mode 100644 beautiful-racket-demo/basic-demo-nth/parser.rkt rename beautiful-racket-demo/{basic-demo => basic-demo-nth}/sinewave.bas (100%) rename beautiful-racket-demo/{basic-demo => basic-demo-nth}/tabs.bas (100%) create mode 100644 beautiful-racket-demo/basic-demo-nth/tokenizer.rkt create mode 100644 beautiful-racket-demo/basic-demo/basic-test.rkt create mode 100644 beautiful-racket-demo/basic-demo/importer.rkt create mode 100644 beautiful-racket-demo/basic-demo/runtime.rkt create mode 100644 beautiful-racket-demo/basic-demo/test-parser.rkt create mode 100644 beautiful-racket-lib/br/exception.rkt diff --git a/beautiful-racket-demo/basic-demo/3dplot.bas b/beautiful-racket-demo/basic-demo-nth/3dplot.bas similarity index 100% rename from beautiful-racket-demo/basic-demo/3dplot.bas rename to beautiful-racket-demo/basic-demo-nth/3dplot.bas diff --git a/beautiful-racket-demo/basic-demo/aceyducey.bas b/beautiful-racket-demo/basic-demo-nth/aceyducey.bas similarity index 100% rename from beautiful-racket-demo/basic-demo/aceyducey.bas rename to beautiful-racket-demo/basic-demo-nth/aceyducey.bas diff --git a/beautiful-racket-demo/basic-demo/amazing.bas b/beautiful-racket-demo/basic-demo-nth/amazing.bas similarity index 100% rename from beautiful-racket-demo/basic-demo/amazing.bas rename to beautiful-racket-demo/basic-demo-nth/amazing.bas diff --git a/beautiful-racket-demo/basic-demo-nth/basic-test.rkt b/beautiful-racket-demo/basic-demo-nth/basic-test.rkt new file mode 100644 index 0000000..6f87e60 --- /dev/null +++ b/beautiful-racket-demo/basic-demo-nth/basic-test.rkt @@ -0,0 +1,4 @@ +#lang basic-demo +10 rem 20 +20 x = 42 +25 print x \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/bounce.bas b/beautiful-racket-demo/basic-demo-nth/bounce.bas similarity index 100% rename from beautiful-racket-demo/basic-demo/bounce.bas rename to beautiful-racket-demo/basic-demo-nth/bounce.bas diff --git a/beautiful-racket-demo/basic-demo/change.bas b/beautiful-racket-demo/basic-demo-nth/change.bas similarity index 100% rename from beautiful-racket-demo/basic-demo/change.bas rename to beautiful-racket-demo/basic-demo-nth/change.bas diff --git a/beautiful-racket-demo/basic-demo/chemist.bas b/beautiful-racket-demo/basic-demo-nth/chemist.bas similarity index 100% rename from beautiful-racket-demo/basic-demo/chemist.bas rename to beautiful-racket-demo/basic-demo-nth/chemist.bas diff --git a/beautiful-racket-demo/basic-demo-nth/colorer.rkt b/beautiful-racket-demo/basic-demo-nth/colorer.rkt new file mode 100644 index 0000000..4734f74 --- /dev/null +++ b/beautiful-racket-demo/basic-demo-nth/colorer.rkt @@ -0,0 +1,51 @@ +#lang br +(require brag/support syntax-color/racket-lexer racket/contract + basic-demo/tokenizer sugar/coerce) + +(define (color-basic ip) + (define postok (basic-lexer ip)) + (define tok (position-token-token postok)) + (define-values (type val) + (cond + [(eof-object? tok) (values eof eof)] + [(string? tok) (values 'string tok)] + [else (values (token-struct-type tok) + (format "~a" (token-struct-val tok)))])) + (values val + (caseq type + [(WHITE) 'white-space] + [(COMMENT) 'comment] + [(NUMBER) 'constant] + [(STRING) 'string] + [else 'keyword]) + #f + (position-offset (position-token-start-pos postok)) + (position-offset (position-token-end-pos postok)))) + + +#;(provide + (contract-out + [color-basic + (input-port? . -> . (values + (or/c string? eof-object?) + symbol? + (or/c symbol? #f) + (or/c exact-positive-integer? #f) + (or/c exact-positive-integer? #f)))])) + +(define (apply-colorer colorer-proc str) + (let loop ([p (open-input-string str)][color-recs empty]) + (define color-rec (values->list (colorer-proc p))) + (if (eof-object? (car color-rec)) + (reverse color-recs) + (loop p (cons color-rec color-recs))))) + +(module+ main + (define str #<datum (filter (λ(s) (syntax-property s 'id)) (syntax-flatten stx))) eq?))) + +(define-macro (basic-module-begin (basic-program PROGRAM-LINE ...)) + (with-pattern ([(UNIQUE-ID ...) + (map (compose1 syntax-local-introduce (λ(id) (datum->syntax #f id))) + (gather-unique-ids #'(PROGRAM-LINE ...)))]) + #'(#%module-begin + (define UNIQUE-ID 0) ... + (provide UNIQUE-ID ...) + (run (sort (cons (line +inf.0 (statement "end")) + (list PROGRAM-LINE ...)) #:key $line-number <))))) + + +(struct exn:line-not-found 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 end-program-signal exn:fail ()) +(define (raise-end-program-signal) + (raise (end-program-signal "" (current-continuation-marks)))) + +(struct end-line-signal exn:fail ()) +(define (raise-end-line-signal) + (raise (end-line-signal "" (current-continuation-marks)))) + +(define (run line-list) + (define lines (list->vector line-list)) + (define (find-index ln) + (or + (for/or ([idx (in-range (vector-length lines))]) + (and (= ($line-number (vector-ref lines idx)) ln) + idx)) + (raise-line-not-found-error ln))) + (void + (with-handlers ([end-program-signal? void]) + (for/fold ([program-counter 0]) + ([i (in-naturals)]) + (let* ([line-thunk ($line-thunk (vector-ref lines program-counter))] + [maybe-line-number (line-thunk)]) + (if (number? maybe-line-number) + (find-index maybe-line-number) + (add1 program-counter))))))) + +(define current-return-stack (make-parameter empty)) + +(define (basic:gosub where) + (let/cc return-k + (current-return-stack (cons return-k (current-return-stack))) + (basic:goto where))) + +(define current-line (make-parameter #f)) +(struct $line (number thunk) #:transparent) +(define-macro (line NUMBER . STATEMENTS) + #'($line NUMBER (λ () + (current-line NUMBER) + (with-handlers ([end-line-signal? (λ _ #f)] + [end-program-signal? raise] + [exn:fail? (λ(exn) + (displayln (format "in line ~a" NUMBER)) + (raise exn))]) + . STATEMENTS)))) + +(define-macro-cases statement + [(statement ID "=" EXPR) #'(basic:let ID EXPR)] + [(statement PROC-NAME . ARGS) + (with-pattern + ([PROC-ID (prefix-id "basic:" #'PROC-NAME)]) + #'(PROC-ID . ARGS))]) + +(define-macro-cases basic:let + [(_ (id-expr ID) EXPR) + #'(set! ID EXPR)] + [(_ (id-expr ID DIM-IDX ...) EXPR) + #'(array-set! ID DIM-IDX ... EXPR)]) + +(define-macro-cases basic:if + [(_ COND-EXPR TRUE-EXPR FALSE-EXPR) + #'(if (true? COND-EXPR) + TRUE-EXPR + FALSE-EXPR)] + [(_ COND-EXPR TRUE-EXPR) + #'(if (true? COND-EXPR) + TRUE-EXPR + (raise-end-line-signal))]) ; special short-circuit rule for one-armed conditional + +(define true? (compose1 not zero?)) +(define (cond->int cond) (if cond 1 0)) +(define (basic:and . args) (cond->int (andmap true? args))) +(define (basic:or . args) (cond->int (ormap true? args))) + +(define-macro-cases id-expr + [(_ ID) #'(cond + [(procedure? ID) (ID)] + [(array? ID) (array-ref ID (make-vector (array-rank ID) 0))] ; no subscript => zeroth element + [else ID])] + [(_ ID EXPR0 EXPR ...) #'(cond + [(procedure? ID) (ID EXPR0 EXPR ...)] + [(array? ID) (array-ref ID EXPR0 EXPR ...)] + [else (error 'id-expr-confused)])]) + +(define-macro-cases expr + [(_ COMP-EXPR) #'COMP-EXPR] + [(_ COMP-EXPR "and" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)] + [(_ COMP-EXPR "or" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)]) + +(define-macro-cases comp-expr + [(_ SUM) #'SUM] + [(_ SUM "=" COMP-EXPR) + #'(cond->int (equal? SUM COMP-EXPR))] ; special case because `=` is overloaded in basic + [(_ 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-macro-cases sum + [(_ SUM) #'SUM] + [(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)] + [(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)]) + +(define-macro-cases product + [(_ "-" VALUE) #'(- VALUE)] + [(_ VALUE) #'VALUE] + [(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)] + [(_ PRODUCT "/" VALUE) #'(/ PRODUCT VALUE)]) + +(define-macro-cases power + [(_ BASE) #'BASE] + [(_ BASE POWER) #'(expt BASE POWER)]) + +(define-macro-cases maybe-negative-val + [(_ "-" ID) #'(- ID)] + [(_ ID) #'ID]) + +(define print-list list) + +(define (basic:print [args #f]) + (define (println [x ""]) + (define xstr (format "~a" x)) + (displayln xstr) + (current-print-position 0)) + (define (print x) + (define xstr (format "~a" x)) + (display xstr) + (current-print-position (+ (current-print-position) (string-length xstr)))) + + (match args + [#f (println)] + [(list print-list-items ... ";" pl) + (begin + (for-each + (λ(pli) + (print (if (number? pli) + (format "~a " pli) + pli))) + print-list-items) + (basic:print pl))] + [(list print-list-items ... ";") (for-each print print-list-items)] + [(list print-list-items ...) + (for-each println print-list-items)])) + +(define current-print-position (make-parameter 0)) +(define (TAB num) (make-string (max 0 (INT (- num (current-print-position)))) #\space)) +(define (INT num) (inexact->exact (truncate num))) +(define (SIN num) (sin num)) +(define (ABS num) (inexact->exact (abs num))) +(define (RND num) (* (random) num)) +(define (EXP num) (exp num)) +(define (SQR num) (sqrt num)) + +(define-macro-cases basic:input + [(_ (print-list . PL-ITEMS) ID ...) + #'(begin + (basic:print (append (print-list . PL-ITEMS) (list ";"))) + (basic:input ID) ...)] + [(_ ID ...) #'(begin + (set! ID (let* ([str (read-line)] + [num (string->number (string-trim str))]) + (or num str))) ...)]) + +(define (basic:goto where) where) + +(define-macro-cases basic:on + [(_ TEST-EXPR "goto" OPTION ...) + #'(basic:goto (list-ref (list OPTION ...) (sub1 TEST-EXPR)))] + [(_ TEST-EXPR "gosub" OPTION ...) + #'(basic:gosub (list-ref (list OPTION ...) (sub1 TEST-EXPR)))]) + + +(define (basic:return) + (define return-k (car (current-return-stack))) + (current-return-stack (cdr (current-return-stack))) + (return-k #f)) + +(define (basic:stop) (basic:end)) +(define (basic:end) (raise-end-program-signal)) + +(require srfi/25) + +(define-macro (basic:dim (id-expr ID EXPR ...) ...) + #'(begin + (set! ID (make-array (apply shape (append (list 0 (add1 EXPR)) ...)))) ...)) + +(define current-for-stack (make-parameter empty)) + +(define (push-for-stack thunk) + (current-for-stack (cons thunk (current-for-stack)))) + +(define (pop-for-stack) + (current-for-stack (cdr (current-for-stack)))) + +(define (in-closed-interval? x left right) + (define cmp (if (< left right) <= >=)) + (cmp left x right)) + +(define-macro-cases basic:for + [(_ VAR START-VALUE END-VALUE) + #'(basic:for VAR START-VALUE END-VALUE 1)] + [(_ VAR START-VALUE END-VALUE STEP-VALUE) + #'(begin + (statement (id-expr VAR) "=" START-VALUE) ; initialize the loop counter + (let/cc return-k ; create a return point + (push-for-stack (cons 'VAR + (λ () ; thunk that increments counter & teleports back to beginning of loop + (define next-val (+ VAR STEP-VALUE)) + (if (next-val . in-closed-interval? . START-VALUE END-VALUE) + (begin + (set! VAR next-val) + (return-k #f)) ; return value for subsequent visits to line + (pop-for-stack))))) + #f))]) ; return value for first visit to line + +(define (handle-next [which #f]) + (unless (pair? (current-for-stack)) (error 'next "for-stack is empty")) + (define for-thunk (cdr (if which + (assq which (current-for-stack)) + (car (current-for-stack))))) + (for-thunk)) + +(define-macro (basic:next VAR ...) + #'(handle-next 'VAR ...)) + +(define-macro (basic:def DEF-ID LAMBDA-ID EXPR) + #'(set! DEF-ID (λ (LAMBDA-ID) EXPR))) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/for.bas b/beautiful-racket-demo/basic-demo-nth/for.bas similarity index 100% rename from beautiful-racket-demo/basic-demo/for.bas rename to beautiful-racket-demo/basic-demo-nth/for.bas diff --git a/beautiful-racket-demo/basic-demo/gosub.bas b/beautiful-racket-demo/basic-demo-nth/gosub.bas similarity index 100% rename from beautiful-racket-demo/basic-demo/gosub.bas rename to beautiful-racket-demo/basic-demo-nth/gosub.bas diff --git a/beautiful-racket-demo/basic-demo/importest.rkt b/beautiful-racket-demo/basic-demo-nth/importest.rkt similarity index 100% rename from beautiful-racket-demo/basic-demo/importest.rkt rename to beautiful-racket-demo/basic-demo-nth/importest.rkt diff --git a/beautiful-racket-demo/basic-demo-nth/main.rkt b/beautiful-racket-demo/basic-demo-nth/main.rkt new file mode 100644 index 0000000..a8fb8ee --- /dev/null +++ b/beautiful-racket-demo/basic-demo-nth/main.rkt @@ -0,0 +1,26 @@ +#lang br/quicklang +(require "parser.rkt" "tokenizer.rkt") + +(module+ reader (provide read-syntax get-info)) + +(define (read-syntax path port) + (define-values (line col pos) (port-next-location port)) + (define port+newline (input-port-append #f port (open-input-string "\n"))) + (port-count-lines! port+newline) + (set-port-next-location! port+newline line col pos) + (define parse-tree (parse path (tokenize port+newline))) + (strip-bindings + #`(module basic-mod basic-demo/expander + #,parse-tree))) + +(define (get-info port mod line col pos) + (define (handle-query key default) + (case key + #;[(color-lexer) + (dynamic-require 'basic-demo/colorer 'color-basic (λ () #f))] + #;[(drracket:indentation) + (dynamic-require 'basic-demo/indenter 'indent-jsonic (λ () #f))] + #;[(drracket:toolbar-buttons) + (dynamic-require 'basic-demo/buttons 'button-list (λ () #f))] + [else default])) + handle-query) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/next-fix.bas b/beautiful-racket-demo/basic-demo-nth/next-fix.bas similarity index 100% rename from beautiful-racket-demo/basic-demo/next-fix.bas rename to beautiful-racket-demo/basic-demo-nth/next-fix.bas diff --git a/beautiful-racket-demo/basic-demo/on.bas b/beautiful-racket-demo/basic-demo-nth/on.bas similarity index 100% rename from beautiful-racket-demo/basic-demo/on.bas rename to beautiful-racket-demo/basic-demo-nth/on.bas diff --git a/beautiful-racket-demo/basic-demo-nth/parser.rkt b/beautiful-racket-demo/basic-demo-nth/parser.rkt new file mode 100644 index 0000000..569b5d3 --- /dev/null +++ b/beautiful-racket-demo/basic-demo-nth/parser.rkt @@ -0,0 +1,42 @@ +#lang brag + +basic-program : line* + +line: NUMBER statement [/":" statement]* + +statement : "def" id /"(" id /")" /"=" expr +| "dim" id-expr [/"," id-expr]* +| "end" | "stop" +| "gosub" expr +| "goto" expr +| "on" expr ("gosub" | "goto") expr [/"," expr]* +| "if" expr /"then" (statement | expr) [/"else" (statement | expr)] +| "input" [print-list /";"] id [/"," id]* +| [/"let"] id-expr "=" expr +| "print" [print-list] +| "return" +| "for" id /"=" expr /"to" expr [/"step" expr] +| "next" [id] + +print-list : expr [[";"] [print-list]] + +expr : comp-expr [("and" | "or") expr] + +comp-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") comp-expr] + +sum : [sum ("+" | "-")] product + +product : [product ("*" | "/")] power + +power : value [/"^" value] + +@value : maybe-negative-val +| id-expr +| /"(" expr /")" +| STRING + +id-expr : id [/"(" expr [/"," expr]* /")"] + +@id : ID + +maybe-negative-val : ["-"] (id-expr | NUMBER) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/sinewave.bas b/beautiful-racket-demo/basic-demo-nth/sinewave.bas similarity index 100% rename from beautiful-racket-demo/basic-demo/sinewave.bas rename to beautiful-racket-demo/basic-demo-nth/sinewave.bas diff --git a/beautiful-racket-demo/basic-demo/tabs.bas b/beautiful-racket-demo/basic-demo-nth/tabs.bas similarity index 100% rename from beautiful-racket-demo/basic-demo/tabs.bas rename to beautiful-racket-demo/basic-demo-nth/tabs.bas diff --git a/beautiful-racket-demo/basic-demo-nth/tokenizer.rkt b/beautiful-racket-demo/basic-demo-nth/tokenizer.rkt new file mode 100644 index 0000000..02d6b73 --- /dev/null +++ b/beautiful-racket-demo/basic-demo-nth/tokenizer.rkt @@ -0,0 +1,68 @@ +#lang br +(require parser-tools/lex + (prefix-in : parser-tools/lex-sre) + brag/support) +(provide tokenize basic-lexer) + +(define-lex-abbrevs + (integer (:+ numeric)) + ;; don't lex the leading "-": muddles "-X" and "Y-X" + (decimal (:or integer (:seq (:? integer) (:seq "." integer))))) + + +(define basic-lexer + (lexer-src-pos + [(eof) eof] + [whitespace (token 'WHITE lexeme #:skip? #t + #:position (pos lexeme-start) + #:line (line lexeme-start) + #:column (col lexeme-start) + #:span (- (pos lexeme-end) + (pos lexeme-start)))] + [(:or (from/to "/*" "*/") + (:: decimal (:+ whitespace) (from/to (uc+lc "rem") "\n"))) + (token 'COMMENT lexeme #:skip? #t + #:position (pos lexeme-start) + #:line (line lexeme-start) + #:column (col lexeme-start) + #:span (- (pos lexeme-end) + (pos lexeme-start)))] + [(:or (uc+lc "print" "for" "to" "step" "if" + "goto" "input" "let" "next" + "return" "clear" "list" "run" + "end" "then" "else" "gosub" + "and" "or" "stop" "let" "def" "dim" "on") + ";" "=" "(" ")" "+" "-" "*" "/" "^" + "<=" ">=" "<>" "<" ">" "=" ":" ",") (token (string-downcase lexeme) + (string-downcase lexeme) + #:position (pos lexeme-start) + #:line (line lexeme-start) + #:column (col lexeme-start) + #:span (- (pos lexeme-end) + (pos lexeme-start)))] + [decimal (token 'NUMBER (string->number lexeme) + #:position (pos lexeme-start) + #:line (line lexeme-start) + #:column (col lexeme-start) + #:span (- (pos lexeme-end) + (pos lexeme-start)))] + [(:: alphabetic (:* (:or alphabetic numeric)) (:? "$")) (token 'ID (string->symbol lexeme) + #:position (pos lexeme-start) + #:line (line lexeme-start) + #:column (col lexeme-start) + #:span (- (pos lexeme-end) + (pos lexeme-start)))] + [(from/to "\"" "\"") (token 'STRING (trim-ends "\"" lexeme "\"") + #:position (+ (pos lexeme-start) 1) + #:line (line lexeme-start) + #:column (+ (col lexeme-start) 1) + #:span (- (pos lexeme-end) + (pos lexeme-start) 2))])) + +(define (tokenize ip) + (port-count-lines! ip) + (define (next-token) (basic-lexer ip)) + next-token) + +(module+ main + (apply-tokenizer tokenize "\n10 rem foo\n15 print x\n20 rem\n")) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/basic-test.rkt b/beautiful-racket-demo/basic-demo/basic-test.rkt new file mode 100644 index 0000000..36468c9 --- /dev/null +++ b/beautiful-racket-demo/basic-demo/basic-test.rkt @@ -0,0 +1,7 @@ +#lang basic-demo +10 rem what? +20 print "hello" +30 rem goto 50 +45 print "shite" +50 print "foobar" +30 goto 50 \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/colorer.rkt b/beautiful-racket-demo/basic-demo/colorer.rkt index 8beb04a..4734f74 100644 --- a/beautiful-racket-demo/basic-demo/colorer.rkt +++ b/beautiful-racket-demo/basic-demo/colorer.rkt @@ -3,11 +3,11 @@ basic-demo/tokenizer sugar/coerce) (define (color-basic ip) - (define postok ((tokenize ip))) + (define postok (basic-lexer ip)) (define tok (position-token-token postok)) (define-values (type val) (cond - [(eof-object? tok) (values 'eof "")] + [(eof-object? tok) (values eof eof)] [(string? tok) (values 'string tok)] [else (values (token-struct-type tok) (format "~a" (token-struct-val tok)))])) @@ -17,30 +17,35 @@ [(COMMENT) 'comment] [(NUMBER) 'constant] [(STRING) 'string] - [else 'no-color]) + [else 'keyword]) #f (position-offset (position-token-start-pos postok)) (position-offset (position-token-end-pos postok)))) -(provide - (contract-out - [color-basic - (input-port? . -> . (values - (or/c string? eof-object?) - symbol? - (or/c symbol? #f) - (or/c exact-positive-integer? #f) - (or/c exact-positive-integer? #f)))])) +#;(provide + (contract-out + [color-basic + (input-port? . -> . (values + (or/c string? eof-object?) + symbol? + (or/c symbol? #f) + (or/c exact-positive-integer? #f) + (or/c exact-positive-integer? #f)))])) -(module+ main - (define p (open-input-string #<list (colorer-proc p))) + (if (eof-object? (car color-rec)) + (reverse color-recs) + (loop p (cons color-rec color-recs))))) -10 rem foo -20 rem foo -30 let x = 42 +(module+ main + (define str #<datum (filter (λ(s) (syntax-property s 'id)) (syntax-flatten stx))) eq?))) - -(define-macro (basic-module-begin (basic-program PROGRAM-LINE ...)) - (with-pattern ([(UNIQUE-ID ...) - (map (compose1 syntax-local-introduce (λ(id) (datum->syntax #f id))) - (gather-unique-ids #'(PROGRAM-LINE ...)))]) - #'(#%module-begin - (define UNIQUE-ID 0) ... - (provide UNIQUE-ID ...) - (run (sort (cons (line +inf.0 (statement "end")) - (list PROGRAM-LINE ...)) #:key $line-number <))))) - - -(struct exn:line-not-found 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 end-program-signal exn:fail ()) -(define (raise-end-program-signal) - (raise (end-program-signal "" (current-continuation-marks)))) - -(struct end-line-signal exn:fail ()) -(define (raise-end-line-signal) - (raise (end-line-signal "" (current-continuation-marks)))) - -(define (run line-list) - (define lines (list->vector line-list)) - (define (find-index ln) - (or - (for/or ([idx (in-range (vector-length lines))]) - (and (= ($line-number (vector-ref lines idx)) ln) - idx)) - (raise-line-not-found-error ln))) - (void - (with-handlers ([end-program-signal? void]) - (for/fold ([program-counter 0]) - ([i (in-naturals)]) - (let* ([line-thunk ($line-thunk (vector-ref lines program-counter))] - [maybe-line-number (line-thunk)]) - (if (number? maybe-line-number) - (find-index maybe-line-number) - (add1 program-counter))))))) - -(define current-return-stack (make-parameter empty)) - -(define (basic:gosub where) - (let/cc return-k - (current-return-stack (cons return-k (current-return-stack))) - (basic:goto where))) - -(define current-line (make-parameter #f)) -(struct $line (number thunk) #:transparent) -(define-macro (line NUMBER . STATEMENTS) - #'($line NUMBER (λ () - (current-line NUMBER) - (with-handlers ([end-line-signal? (λ _ #f)] - [end-program-signal? raise] - [exn:fail? (λ(exn) - (displayln (format "in line ~a" NUMBER)) - (raise exn))]) - . STATEMENTS)))) - -(define-macro-cases statement - [(statement ID "=" EXPR) #'(basic:let ID EXPR)] - [(statement PROC-NAME . ARGS) - (with-pattern - ([PROC-ID (prefix-id "basic:" #'PROC-NAME)]) - #'(PROC-ID . ARGS))]) - -(define-macro-cases basic:let - [(_ (id-expr ID) EXPR) - #'(set! ID EXPR)] - [(_ (id-expr ID DIM-IDX ...) EXPR) - #'(array-set! ID DIM-IDX ... EXPR)]) - -(define-macro-cases basic:if - [(_ COND-EXPR TRUE-EXPR FALSE-EXPR) - #'(if (true? COND-EXPR) - TRUE-EXPR - FALSE-EXPR)] - [(_ COND-EXPR TRUE-EXPR) - #'(if (true? COND-EXPR) - TRUE-EXPR - (raise-end-line-signal))]) ; special short-circuit rule for one-armed conditional - -(define true? (compose1 not zero?)) -(define (cond->int cond) (if cond 1 0)) -(define (basic:and . args) (cond->int (andmap true? args))) -(define (basic:or . args) (cond->int (ormap true? args))) - -(define-macro-cases id-expr - [(_ ID) #'(cond - [(procedure? ID) (ID)] - [(array? ID) (array-ref ID (make-vector (array-rank ID) 0))] ; no subscript => zeroth element - [else ID])] - [(_ ID EXPR0 EXPR ...) #'(cond - [(procedure? ID) (ID EXPR0 EXPR ...)] - [(array? ID) (array-ref ID EXPR0 EXPR ...)] - [else (error 'id-expr-confused)])]) - -(define-macro-cases expr - [(_ COMP-EXPR) #'COMP-EXPR] - [(_ COMP-EXPR "and" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)] - [(_ COMP-EXPR "or" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)]) - -(define-macro-cases comp-expr - [(_ SUM) #'SUM] - [(_ SUM "=" COMP-EXPR) - #'(cond->int (equal? SUM COMP-EXPR))] ; special case because `=` is overloaded in basic - [(_ 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-macro-cases sum - [(_ SUM) #'SUM] - [(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)] - [(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)]) - -(define-macro-cases product - [(_ "-" VALUE) #'(- VALUE)] - [(_ VALUE) #'VALUE] - [(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)] - [(_ PRODUCT "/" VALUE) #'(/ PRODUCT VALUE)]) - -(define-macro-cases power - [(_ BASE) #'BASE] - [(_ BASE POWER) #'(expt BASE POWER)]) - -(define-macro-cases maybe-negative-val - [(_ "-" ID) #'(- ID)] - [(_ ID) #'ID]) - -(define print-list list) - -(define (basic:print [args #f]) - (define (println [x ""]) - (define xstr (format "~a" x)) - (displayln xstr) - (current-print-position 0)) - (define (print x) - (define xstr (format "~a" x)) - (display xstr) - (current-print-position (+ (current-print-position) (string-length xstr)))) - - (match args - [#f (println)] - [(list print-list-items ... ";" pl) - (begin - (for-each - (λ(pli) - (print (if (number? pli) - (format "~a " pli) - pli))) - print-list-items) - (basic:print pl))] - [(list print-list-items ... ";") (for-each print print-list-items)] - [(list print-list-items ...) - (for-each println print-list-items)])) - -(define current-print-position (make-parameter 0)) -(define (TAB num) (make-string (max 0 (INT (- num (current-print-position)))) #\space)) -(define (INT num) (inexact->exact (truncate num))) -(define (SIN num) (sin num)) -(define (ABS num) (inexact->exact (abs num))) -(define (RND num) (* (random) num)) -(define (EXP num) (exp num)) -(define (SQR num) (sqrt num)) - -(define-macro-cases basic:input - [(_ (print-list . PL-ITEMS) ID ...) - #'(begin - (basic:print (append (print-list . PL-ITEMS) (list ";"))) - (basic:input ID) ...)] - [(_ ID ...) #'(begin - (set! ID (let* ([str (read-line)] - [num (string->number (string-trim str))]) - (or num str))) ...)]) - -(define (basic:goto where) where) - -(define-macro-cases basic:on - [(_ TEST-EXPR "goto" OPTION ...) - #'(basic:goto (list-ref (list OPTION ...) (sub1 TEST-EXPR)))] - [(_ TEST-EXPR "gosub" OPTION ...) - #'(basic:gosub (list-ref (list OPTION ...) (sub1 TEST-EXPR)))]) - - -(define (basic:return) - (define return-k (car (current-return-stack))) - (current-return-stack (cdr (current-return-stack))) - (return-k #f)) - -(define (basic:stop) (basic:end)) -(define (basic:end) (raise-end-program-signal)) - -(require srfi/25) - -(define-macro (basic:dim (id-expr ID EXPR ...) ...) - #'(begin - (set! ID (make-array (apply shape (append (list 0 (add1 EXPR)) ...)))) ...)) - -(define current-for-stack (make-parameter empty)) - -(define (push-for-stack thunk) - (current-for-stack (cons thunk (current-for-stack)))) - -(define (pop-for-stack) - (current-for-stack (cdr (current-for-stack)))) - -(define (in-closed-interval? x left right) - (define cmp (if (< left right) <= >=)) - (cmp left x right)) - -(define-macro-cases basic:for - [(_ VAR START-VALUE END-VALUE) - #'(basic:for VAR START-VALUE END-VALUE 1)] - [(_ VAR START-VALUE END-VALUE STEP-VALUE) - #'(begin - (statement (id-expr VAR) "=" START-VALUE) ; initialize the loop counter - (let/cc return-k ; create a return point - (push-for-stack (cons 'VAR - (λ () ; thunk that increments counter & teleports back to beginning of loop - (define next-val (+ VAR STEP-VALUE)) - (if (next-val . in-closed-interval? . START-VALUE END-VALUE) - (begin - (set! VAR next-val) - (return-k #f)) ; return value for subsequent visits to line - (pop-for-stack))))) - #f))]) ; return value for first visit to line - -(define (handle-next [which #f]) - (unless (pair? (current-for-stack)) (error 'next "for-stack is empty")) - (define for-thunk (cdr (if which - (assq which (current-for-stack)) - (car (current-for-stack))))) - (for-thunk)) - -(define-macro (basic:next VAR ...) - #'(handle-next 'VAR ...)) - -(define-macro (basic:def DEF-ID LAMBDA-ID EXPR) - #'(set! DEF-ID (λ (LAMBDA-ID) EXPR))) \ No newline at end of file +(define-exn-srcloc duplicate-line-number exn:fail) + +(define-macro (b-module-begin (b-program LINE ...)) + #'(#%module-begin + (define lines (sort (list LINE ...) #:key $line-number <)) + (unless (apply < (map $line-number lines)) + (raise-duplicate-line-number + ($line-srcloc (check-duplicates lines = #:key $line-number)))) + (run lines))) + +(struct $line (number thunk srcloc) #:transparent) + +(define-macro (b-line LINE-NUMBER STATEMENT) + (with-pattern ([SRCLOC (syntax-srcloc caller-stx)]) + #'($line LINE-NUMBER (thunk STATEMENT) SRCLOC))) + +(define-macro (b-statement (PROC-NAME ARG ...)) + #'(begin (PROC-NAME ARG ...))) + +(define (b-rem str) #f) +(define (b-print str) (displayln str)) +(define (b-goto line-number) line-number) + +(define-exn end-program-signal exn:fail) +(define (b-end) (raise-end-program-signal)) + +(define-exn-srcloc line-not-found exn:fail) + +(define (run lines) + (define line-vec (list->vector lines)) + (define line-idx-table (for/hasheqv ([(line idx) (in-indexed line-vec)]) + (values ($line-number line) idx))) + (with-handlers ([end-program-signal? void]) + (for/fold ([line-idx 0]) + ([i (in-naturals)]) + (unless (< line-idx (vector-length line-vec)) (b-end)) + (define this-line (vector-ref line-vec line-idx)) + (define this-thunk ($line-thunk this-line)) + (define this-result (this-thunk)) + (if (exact-positive-integer? this-result) + (hash-ref line-idx-table this-result + (thunk (raise-line-not-found ($line-srcloc this-line)))) + (add1 line-idx))))) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/importer.rkt b/beautiful-racket-demo/basic-demo/importer.rkt new file mode 100644 index 0000000..6395cd1 --- /dev/null +++ b/beautiful-racket-demo/basic-demo/importer.rkt @@ -0,0 +1,2 @@ +#lang br +(require "basic-test.rkt") \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/main.rkt b/beautiful-racket-demo/basic-demo/main.rkt index 4736a06..2635844 100644 --- a/beautiful-racket-demo/basic-demo/main.rkt +++ b/beautiful-racket-demo/basic-demo/main.rkt @@ -1,7 +1,7 @@ #lang br/quicklang (require "parser.rkt" "tokenizer.rkt") -(module+ reader (provide read-syntax get-info)) +(module+ reader (provide read-syntax)) (define (read-syntax path port) (define-values (line col pos) (port-next-location port)) @@ -12,15 +12,3 @@ (strip-bindings #`(module basic-mod basic-demo/expander #,parse-tree))) - -(define (get-info port mod line col pos) - (define (handle-query key default) - (case key - [(color-lexer) - (dynamic-require 'basic-demo/colorer 'color-basic)] - #;[(drracket:indentation) - (dynamic-require 'basic-demo/indenter 'indent-jsonic)] - #;[(drracket:toolbar-buttons) - (dynamic-require 'basic-demo/buttons 'button-list)] - [else default])) - handle-query) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/parser.rkt b/beautiful-racket-demo/basic-demo/parser.rkt index 569b5d3..8fff621 100644 --- a/beautiful-racket-demo/basic-demo/parser.rkt +++ b/beautiful-racket-demo/basic-demo/parser.rkt @@ -1,42 +1,18 @@ #lang brag -basic-program : line* +b-program : b-line* -line: NUMBER statement [/":" statement]* +b-line: NUMBER b-statement -statement : "def" id /"(" id /")" /"=" expr -| "dim" id-expr [/"," id-expr]* -| "end" | "stop" -| "gosub" expr -| "goto" expr -| "on" expr ("gosub" | "goto") expr [/"," expr]* -| "if" expr /"then" (statement | expr) [/"else" (statement | expr)] -| "input" [print-list /";"] id [/"," id]* -| [/"let"] id-expr "=" expr -| "print" [print-list] -| "return" -| "for" id /"=" expr /"to" expr [/"step" expr] -| "next" [id] +b-statement: b-rem +| b-print +| b-goto +| b-end -print-list : expr [[";"] [print-list]] +b-rem : REM -expr : comp-expr [("and" | "or") expr] +b-print : /"print" STRING -comp-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") comp-expr] +b-goto : /"goto" NUMBER -sum : [sum ("+" | "-")] product - -product : [product ("*" | "/")] power - -power : value [/"^" value] - -@value : maybe-negative-val -| id-expr -| /"(" expr /")" -| STRING - -id-expr : id [/"(" expr [/"," expr]* /")"] - -@id : ID - -maybe-negative-val : ["-"] (id-expr | NUMBER) \ No newline at end of file +b-end : /"end" \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/runtime.rkt b/beautiful-racket-demo/basic-demo/runtime.rkt new file mode 100644 index 0000000..be963de --- /dev/null +++ b/beautiful-racket-demo/basic-demo/runtime.rkt @@ -0,0 +1,3 @@ +#lang br +(provide (all-defined-out)) +(define current-print-status (make-parameter #t)) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/test-parser.rkt b/beautiful-racket-demo/basic-demo/test-parser.rkt new file mode 100644 index 0000000..df6a860 --- /dev/null +++ b/beautiful-racket-demo/basic-demo/test-parser.rkt @@ -0,0 +1,11 @@ +#lang br +(require "tokenizer.rkt" "parser.rkt" brag/support) + +(define str #<number lexeme) + #:position (pos lexeme-start) + #:line (line lexeme-start) + #:column (col lexeme-start) + #:span (- (pos lexeme-end) + (pos lexeme-start)))] + [(from/to "\"" "\"") + (token 'STRING + (trim-ends "\"" lexeme "\"") + #:position (pos lexeme-start) + #:line (line lexeme-start) + #:column (col lexeme-start) + #:span (- (pos lexeme-end) + (pos lexeme-start)))])) (define (tokenize ip) (port-count-lines! ip) - (define (next-token) - (define get-token - (lexer-src-pos - [(eof) eof] - [whitespace (token 'WHITE lexeme #:skip? #t)] - [(from/to "/*" "*/") (token 'COMMENT lexeme #:skip? #t)] - [(:: positive-number (:+ whitespace) (from/to (uc+lc "rem") "\n")) (token 'COMMENT lexeme #:skip? #t)] - [(:or (uc+lc "print" "for" "to" "step" "if" - "goto" "input" "let" "next" - "return" "clear" "list" "run" - "end" "then" "else" "gosub" - "and" "or" "stop" "let" "def" "dim" "on") - ";" "=" "(" ")" "+" "-" "*" "/" "^" - "<=" ">=" "<>" "<" ">" "=" ":" ",") (string-downcase lexeme)] - [positive-number (token 'NUMBER (string->number lexeme) - #:position (pos lexeme-start) - #:line (line lexeme-start) - #:column (col lexeme-start) - #:span (- (pos lexeme-end) - (pos lexeme-start)))] - [(:: alphabetic (:* (:or alphabetic numeric)) (:? "$")) (token 'ID (string->symbol lexeme) - #:position (pos lexeme-start) - #:line (line lexeme-start) - #:column (col lexeme-start) - #:span (- (pos lexeme-end) - (pos lexeme-start)))] - [(from/to "\"" "\"") (token 'STRING (trim-ends "\"" lexeme "\"") - #:position (+ (pos lexeme-start) 1) - #:line (line lexeme-start) - #:column (+ (col lexeme-start) 1) - #:span (- (pos lexeme-end) - (pos lexeme-start) 2))])) - (get-token ip)) - next-token) \ No newline at end of file + (thunk (basic-lexer ip))) \ No newline at end of file diff --git a/beautiful-racket-lib/br/exception.rkt b/beautiful-racket-lib/br/exception.rkt new file mode 100644 index 0000000..77241fc --- /dev/null +++ b/beautiful-racket-lib/br/exception.rkt @@ -0,0 +1,28 @@ +#lang racket/base +(require (for-syntax racket/base br/syntax) br/define racket/match) +(provide (all-defined-out)) + +(define-macro (define-exn EXN-ID BASE-EXN) + (with-pattern ([RAISE-EXN-ID (prefix-id "raise-" #'EXN-ID)]) + #'(begin + (struct EXN-ID BASE-EXN () #:transparent) + (define (RAISE-EXN-ID) + (raise (EXN-ID (format "error: ~a" 'EXN-ID) (current-continuation-marks))))))) + +(define-macro (define-exn-srcloc EXN-ID BASE-EXN) + (with-pattern ([RAISE-EXN-ID (prefix-id "raise-" #'EXN-ID)]) + #'(begin + (define-struct (EXN-ID BASE-EXN) + (a-srcloc) #:transparent + #:property prop:exn:srclocs + (lambda (a-struct) + (match a-struct + [(struct EXN-ID + (msg marks a-srcloc)) + (list a-srcloc)]))) + (define RAISE-EXN-ID + (case-lambda + [(srcloc) + (raise (EXN-ID (format "error: ~a" 'EXN-ID) (current-continuation-marks) srcloc))] + [() + (raise (EXN-ID (format "error: ~a" 'EXN-ID) (current-continuation-marks)))]))))) \ No newline at end of file diff --git a/beautiful-racket-lib/br/main.rkt b/beautiful-racket-lib/br/main.rkt index bfccd9b..b1d1e2c 100644 --- a/beautiful-racket-lib/br/main.rkt +++ b/beautiful-racket-lib/br/main.rkt @@ -1,10 +1,10 @@ #lang racket/base (require racket/provide racket/list racket/string racket/format racket/match racket/port racket/function - br/define br/syntax br/datum br/debug br/cond br/case br/list racket/class racket/vector br/reader-utils + br/define br/syntax br/datum br/debug br/cond br/case br/exception br/list racket/class racket/vector br/reader-utils (for-syntax racket/base racket/syntax br/syntax br/debug br/define br/datum)) (provide (all-from-out racket/base) (all-from-out racket/list racket/string racket/format racket/match racket/port racket/function - br/syntax br/datum br/debug br/cond br/case br/list racket/class racket/vector br/define br/reader-utils) + br/syntax br/datum br/debug br/cond br/case br/exception br/list racket/class racket/vector br/define br/reader-utils) (for-syntax (all-from-out racket/base racket/syntax br/syntax br/debug br/datum)) (for-syntax caller-stx with-shared-id)) ; from br/define diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index 50192bf..c77bb49 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/beautiful-racket-lib/br/syntax.rkt @@ -115,4 +115,11 @@ (define x (syntax-property* #'foo ['bar #t] ['zam 'boni])) (check-false (syntax-property* x 'foo)) (check-true (syntax-property* x 'bar)) - (check-equal? (syntax-property* x 'foo 'bar 'zam) '(#f #t boni))) \ No newline at end of file + (check-equal? (syntax-property* x 'foo 'bar 'zam) '(#f #t boni))) + +(define (syntax-srcloc stx) + (srcloc (syntax-source stx) + (syntax-line stx) + (syntax-column stx) + (syntax-position stx) + (syntax-span stx))) \ No newline at end of file