From 3d8f7f2ded55df1fa6f095459cc32e9b5096e94a Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 20 Jan 2017 14:29:02 -0800 Subject: [PATCH] fixes --- beautiful-racket-demo/basic-demo/expander.rkt | 57 +++++++---------- beautiful-racket-demo/basic-demo/main.rkt | 16 ++++- beautiful-racket-demo/basic-demo/parser.rkt | 7 +-- beautiful-racket-demo/basic-demo/reader.rkt | 6 -- .../basic-demo/tokenizer.rkt | 62 +++++++++++-------- 5 files changed, 75 insertions(+), 73 deletions(-) delete mode 100644 beautiful-racket-demo/basic-demo/reader.rkt diff --git a/beautiful-racket-demo/basic-demo/expander.rkt b/beautiful-racket-demo/basic-demo/expander.rkt index 892992b..4b7620b 100644 --- a/beautiful-racket-demo/basic-demo/expander.rkt +++ b/beautiful-racket-demo/basic-demo/expander.rkt @@ -1,8 +1,7 @@ -#lang br +#lang br/quicklang (require (for-syntax syntax/strip-context)) (provide #%top-interaction #%app #%datum (rename-out [basic-module-begin #%module-begin]) - (rename-out [basic-top #%top]) (all-defined-out)) ; BASIC implementation details @@ -20,13 +19,9 @@ #'(#%module-begin (define UNIQUE-ID 0) ... (provide UNIQUE-ID ...) - (run PROGRAM-LINE ... (line #f (statement "end")))))) + (run (sort (cons (line +inf.0 (statement "end")) + (list PROGRAM-LINE ...)) #:key $line-number <))))) -; #%app and #%datum have to be present to make #%top work -(define-macro (basic-top . ID) - #'(begin - (displayln (format "got unbound identifier: ~a" 'ID)) - (procedure-rename (λ xs (cons 'ID xs)) (string->symbol (format "undefined:~a" 'ID))))) (struct exn:line-not-found exn:fail ()) (define (raise-line-not-found-error ln) @@ -43,13 +38,13 @@ (define (raise-end-line-signal) (raise (end-line-signal "" (current-continuation-marks)))) -(define (run . line-list) +(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)) + (and (= ($line-number (vector-ref lines idx)) ln) + idx)) (raise-line-not-found-error ln))) (void (with-handlers ([end-program-signal? void]) @@ -61,15 +56,15 @@ (find-index maybe-line-number) (add1 program-counter))))))) -(define return-stack empty) +(define current-return-stack (make-parameter empty)) (define (basic:gosub where) (let/cc return-k - (set! return-stack (cons return-k return-stack)) + (current-return-stack (cons return-k (current-return-stack))) (basic:goto where))) (define current-line (make-parameter #f)) -(struct $line (number thunk)) +(struct $line (number thunk) #:transparent) (define-macro (line NUMBER . STATEMENTS) #'($line NUMBER (λ () (current-line NUMBER) @@ -89,9 +84,7 @@ (define-macro-cases basic:let [(_ (id-expr ID) EXPR) - #'(begin - #;(displayln (format "setting ~a = ~a in ~a" 'ID EXPR (current-line))) - (set! ID EXPR))] + #'(set! ID EXPR)] [(_ (id-expr ID DIM-IDX ...) EXPR) #'(array-set! ID DIM-IDX ... EXPR)]) @@ -151,11 +144,7 @@ [(_ BASE) #'BASE] [(_ BASE POWER) #'(expt BASE POWER)]) -(define-macro-cases number - [(_ "-" NUM) #'(- NUM)] - [(_ NUM) #'NUM]) - -(define-macro-cases id-val +(define-macro-cases maybe-negative-val [(_ "-" ID) #'(- ID)] [(_ ID) #'ID]) @@ -165,11 +154,11 @@ (define (println [x ""]) (define xstr (format "~a" x)) (displayln xstr) - (set! current-print-position 0)) + (current-print-position 0)) (define (print x) (define xstr (format "~a" x)) (display xstr) - (set! current-print-position (+ current-print-position (string-length xstr)))) + (current-print-position (+ (current-print-position) (string-length xstr)))) (match args [#f (println)] @@ -186,8 +175,8 @@ [(list print-list-items ...) (for-each println print-list-items)])) -(define current-print-position 0) -(define (TAB num) (make-string (max 0 (INT (- num current-print-position))) #\space)) +(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))) @@ -215,8 +204,8 @@ (define (basic:return) - (define return-k (car return-stack)) - (set! return-stack (cdr return-stack)) + (define return-k (car (current-return-stack))) + (current-return-stack (cdr (current-return-stack))) (return-k #f)) (define (basic:stop) (basic:end)) @@ -228,13 +217,13 @@ #'(begin (set! ID (make-array (apply shape (append (list 0 (add1 EXPR)) ...)))) ...)) -(define for-stack empty) +(define current-for-stack (make-parameter empty)) (define (push-for-stack thunk) - (set! for-stack (cons thunk for-stack))) + (current-for-stack (cons thunk (current-for-stack)))) (define (pop-for-stack) - (set! for-stack (cdr for-stack))) + (current-for-stack (cdr (current-for-stack)))) (define (in-closed-interval? x left right) (define cmp (if (< left right) <= >=)) @@ -258,10 +247,10 @@ #f))]) ; return value for first visit to line (define (handle-next [which #f]) - (unless (pair? for-stack) (error 'next "for-stack is empty")) + (unless (pair? (current-for-stack)) (error 'next "for-stack is empty")) (define for-thunk (cdr (if which - (assq which for-stack) - (car for-stack)))) + (assq which (current-for-stack)) + (car (current-for-stack))))) (for-thunk)) (define-macro (basic:next VAR ...) diff --git a/beautiful-racket-demo/basic-demo/main.rkt b/beautiful-racket-demo/basic-demo/main.rkt index 9537fd6..c6ee74a 100644 --- a/beautiful-racket-demo/basic-demo/main.rkt +++ b/beautiful-racket-demo/basic-demo/main.rkt @@ -1,4 +1,14 @@ #lang br/quicklang -(module reader br - (require "reader.rkt") - (provide read-syntax)) +(require "parser.rkt" "tokenizer.rkt") + +(module+ reader (provide read-syntax)) + +(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))) \ 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 7e908a1..569b5d3 100644 --- a/beautiful-racket-demo/basic-demo/parser.rkt +++ b/beautiful-racket-demo/basic-demo/parser.rkt @@ -30,16 +30,13 @@ product : [product ("*" | "/")] power power : value [/"^" value] -@value : id-val +@value : maybe-negative-val | id-expr | /"(" expr /")" -| number | STRING id-expr : id [/"(" expr [/"," expr]* /")"] @id : ID -id-val : ["-"] id-expr - -number : ["-"] NUMBER \ No newline at end of file +maybe-negative-val : ["-"] (id-expr | NUMBER) \ No newline at end of file diff --git a/beautiful-racket-demo/basic-demo/reader.rkt b/beautiful-racket-demo/basic-demo/reader.rkt deleted file mode 100644 index 61e31d4..0000000 --- a/beautiful-racket-demo/basic-demo/reader.rkt +++ /dev/null @@ -1,6 +0,0 @@ -#lang br -(require br/reader-utils "parser.rkt" "tokenizer.rkt") - -(define-read-and-read-syntax (source-path input-port) - #`(module bf-mod basic-demo/expander - #,(parse source-path (tokenize input-port)))) diff --git a/beautiful-racket-demo/basic-demo/tokenizer.rkt b/beautiful-racket-demo/basic-demo/tokenizer.rkt index 3149ce9..8180966 100644 --- a/beautiful-racket-demo/basic-demo/tokenizer.rkt +++ b/beautiful-racket-demo/basic-demo/tokenizer.rkt @@ -1,34 +1,46 @@ #lang br -(require parser-tools/lex parser-tools/lex-sre - brag/support - racket/string) +(require parser-tools/lex (prefix-in : parser-tools/lex-sre) + brag/support racket/string) (provide tokenize) (define-lex-abbrevs - (natural (repetition 1 +inf.0 numeric)) -;; don't lex the leading "-": muddles "-X" and "Y-X" - (number (union (seq natural) - (seq (? natural) (seq "." natural)))) - (quoted-string (seq "\"" (repetition 0 +inf.0 (char-complement "\"")) "\""))) + (positive-integer (:+ numeric)) + ;; don't lex the leading "-": muddles "-X" and "Y-X" + (positive-number (:or positive-integer (:seq (:? positive-integer) (:seq "." positive-integer))))) -(define (tokenize input-port) +(define (tokenize ip) + (port-count-lines! ip) (define (next-token) (define get-token (lexer-src-pos [(eof) eof] - [(seq "/*" (complement (seq any-string "*/" any-string)) "*/") (get-token input-port)] - [(union #\tab #\space #\newline - (seq number " REM" (repetition 0 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)] - [(union "PRINT" "print" "FOR" "for" "TO" "to" "STEP" "step" "IF" "if" - "GOTO" "goto" "INPUT" "input" "LET" "let" "NEXT" "next" - "RETURN" "return" "CLEAR" "clear" "LIST" "list" "RUN" "run" - "END" "end" "THEN" "then" "ELSE" "else" "GOSUB" "gosub" - "AND" "and" "OR" "or" "STOP" "stop" "LET" "let" "DEF" "def" "DIM" "dim" "ON" "on" - ";" "=" "(" ")" "+" "-" "*" "/" "^" - "<=" ">=" "<>" "<" ">" "=" ":" ",") (string-downcase lexeme)] - [number (token 'NUMBER (string->number lexeme))] - [(seq upper-case (repetition 0 +inf.0 (or upper-case numeric)) (? "$")) (token 'ID (string->symbol lexeme))] - [quoted-string (token 'STRING (string-trim lexeme "\""))])) - (get-token input-port)) - next-token) - + [whitespace (next-token)] + [(from/to "/*" "*/") (next-token)] + [(:: positive-number (:+ whitespace) (from/to (uc+lc "rem") "\n")) (next-token)] + [(: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