diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index 9c9ba65..e72b121 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/beautiful-racket-lib/br/define.rkt @@ -2,38 +2,87 @@ (require (for-syntax racket/base syntax/parse racket/syntax syntax/datum syntax/strip-context) sugar/define) (provide (all-defined-out)) +;; everything is prefixed br: whether it needs it or not so it can be stripped by #lang br -(define-syntax-rule (br:debug-define (syntax (id pat-arg ... . rest-arg)) body-exp) - (br:define #'(id pat-arg ... . rest-arg) - #`(begin - (for-each displayln - (list - (format "input pattern = #'~a" '#,'(id pat-arg ... . rest-arg)) - (format "output pattern = #'~a" (cadr '#,'body-exp)) - (format "invoked as = ~a" (syntax->datum #'(id pat-arg ... . rest-arg))) - (format "expanded as = ~a" '#,(syntax->datum body-exp)) - (format "evaluated as = ~a" #,body-exp))) - #,body-exp))) - +;; todo: support `else` case +(define-syntax (br:define-cases stx) + (define-syntax-class syntaxed-id + #:literals (syntax) + #:description "id in syntaxed form" + (pattern (syntax name:id))) + + (define-syntax-class syntaxed-thing + #:literals (syntax) + #:description "some datum in syntaxed form" + (pattern (syntax thing:expr))) + + (syntax-parse stx + #:literals (syntax) + + ;; defective for syntax or function + [(_ top-id) + (raise-syntax-error 'define-cases "no cases given" (syntax->datum #'top-id))] + + ;; defective for syntax + [(_ (sid:syntaxed-id _ ...) _ ...) ; (define (#'f1 stx) expr ...) + (raise-syntax-error 'define-cases "definition of a syntax transformer must use lambda notation, because otherwise it's too easy to confuse the compile-time shape and the run-time shape" (syntax->datum #'sid.name))] + + ;; syntax matcher + [(_ top-id:syntaxed-id [(syntax pat) body ...] ...+) + #'(define-syntax top-id.name (λ (stx) + (define result + (syntax-case stx () + [pat body ...] ... + [else (raise-syntax-error 'define-cases (format "no matching case for syntax pattern `~a`" (syntax->datum stx)) (syntax->datum #'top-id.name))])) + (if (not (syntax? result)) + (datum->syntax stx result) + result)))] + + ;; function matcher + [(_ top-id:id [(_ pat-arg ... . rest-arg) body ...] ...) + #'(define top-id + (case-lambda + [(pat-arg ... . rest-arg) body ...] ... + [else (raise-syntax-error 'define-cases "no matching case for argument pattern" (object-name top-id))]))])) (module+ test - (require rackunit racket/port) - (parameterize ([current-output-port (open-output-nowhere)]) - (check-equal? (let () - (br:debug-define #'(foo X Y Z) - #'(apply + (list X Y Z))) - (foo 1 2 3)) 6) - (check-equal? (let () - (br:debug-define #'(foo X ...) #'(apply * (list X ...))) - (foo 10 11 12)) 1320))) + (require rackunit) + (define foo-val 'got-foo-val) + (define (foo-func) 'got-foo-func) + (br:define-cases #'op + [#'(_ "+") #''got-plus] + [#'(_ arg) #''got-something-else] + [#'(_) #'(foo-func)] + [#'_ #'foo-val]) + + (check-equal? (op "+") 'got-plus) + (check-equal? (op 42) 'got-something-else) + (check-equal? (op) 'got-foo-func) + (check-equal? op 'got-foo-val) + + (br:define-cases f + [(_ arg) (add1 arg)] + [(_ arg1 arg2) (+ arg1 arg2)]) + + (check-equal? (f 42) 43) + (check-equal? (f 42 5) 47) + + ;; todo: error from define-cases not trapped by check-exn + ;;(check-exn exn:fail:syntax? (λ _ (define-cases (#'times stx stx2) #'*))) + + ) + (define-syntax (br:define stx) + + ;;todo: share syntax classes + (define-syntax-class syntaxed-id #:literals (syntax) #:description "id in syntaxed form" (pattern (syntax name:id))) - + (define-syntax-class syntaxed-thing #:literals (syntax) #:description "some datum in syntaxed form" @@ -41,23 +90,19 @@ (syntax-parse stx #:literals (syntax) + + ;; syntax [(_ (syntax (id pat-arg ... . rest-arg)) body ...) ; (define #'(foo arg) #'(+ arg arg)) - #'(define-syntax id (λ (stx) - (define result - (syntax-case stx () - [(_ pat-arg ... . rest-arg) body ...])) - (if (not (syntax? result)) - (datum->syntax stx result) - result)))] + #'(br:define-cases (syntax id) [(syntax (_ pat-arg ... . rest-arg)) body ...])] [(_ sid:syntaxed-id sid2:syntaxed-id) ; (define #'f1 #'f2) - #'(define-syntax sid.name (make-rename-transformer sid2))] - - [(_ sid:syntaxed-id sid2:syntaxed-thing) ; (define #'f1 #'42) - #'(define-syntax sid.name (λ (stx) sid2))] + #'(define-syntax sid.name (make-rename-transformer sid2))] + + [(_ (syntax id) (syntax thing)) ; (define #'f1 #'42) + #'(br:define-cases (syntax id) [#'_ (syntax thing)])] [(_ (sid:syntaxed-id stx-arg ...) expr ...) ; (define (#'f1 stx) expr ...) - (raise-syntax-error 'define "definition of a syntax transformer must use lambda notation, because otherwise it's too easy to confuse the compile-time shape and the run-time shape" (syntax->datum #'sid.name))] + (raise-syntax-error 'define "definition of a syntax transformer must use lambda notation, because otherwise it's too easy to confuse the compile-time shape and the run-time shape" (syntax->datum #'sid.name))] [(_ sid:syntaxed-id (λ (stx-arg ...) expr ...)) ; (define #'f1 (λ(stx) expr ...) #:fail-when (not (= (length (syntax->datum #'(stx-arg ...))) 1)) @@ -69,63 +114,53 @@ (module+ test (require rackunit) (br:define #'plus (λ(stx) #'+)) - (br:define #'plusser #'plus) - (br:define #'(times arg) #'(* arg arg)) - (br:define #'timeser #'times) - (br:define #'fortytwo #'42) (check-equal? (plus 42) +) - (check-equal? plusser +) + (br:define #'plusser #'plus) (check-equal? (plusser 42) +) + (check-equal? plusser +) + (br:define #'(times arg) #'(* arg arg)) (check-equal? (times 10) 100) + (br:define #'timeser #'times) (check-equal? (timeser 12) 144) + (br:define #'fortytwo #'42) + (check-equal? fortytwo 42) (check-equal? (let () (br:define #'(foo x) (with-syntax ([zam +]) #'(zam x x))) (foo 42)) 84) ;; todo: error from define not trapped by check-exn #;(check-exn exn:fail:syntax? (λ _ (br:define (#'times stx stx2) #'*))) - (check-equal? fortytwo 42) (begin (br:define #'(redefine ID) #'(define ID 42)) (redefine zoombar) (check-equal? zoombar 42))) -;; todo: support `else` case -(define-syntax (br:define-cases stx) - (syntax-parse stx - #:literals (syntax) - ; (define-cases #'foo [#'(_ arg) #'(+ arg arg)] [#'(_ 42 bar) #'42] ...) - [(_ (syntax top-id) [(syntax (_ pat-arg ... . rest-arg)) body ...] ...) - #'(define-syntax top-id (λ (stx) - (define result - (syntax-case stx () - [(_ pat-arg ... . rest-arg) body ...] ...)) - (if (not (syntax? result)) - (datum->syntax stx result) - result)))] - - [(_ top-id [(_ pat-arg ... . rest-arg) body ...] ...) - #'(define top-id - (case-lambda - [(pat-arg ... . rest-arg) body ...] ...))])) +(define-syntax-rule (br:debug-define (syntax (id pat-arg ... . rest-arg)) body-exp) + (br:define #'(id pat-arg ... . rest-arg) + #`(begin + (for-each displayln + (list + (format "input pattern = #'~a" '#,'(id pat-arg ... . rest-arg)) + (format "output pattern = #'~a" (cadr '#,'body-exp)) + (format "invoked as = ~a" (syntax->datum #'(id pat-arg ... . rest-arg))) + (format "expanded as = ~a" '#,(syntax->datum body-exp)) + (format "evaluated as = ~a" #,body-exp))) + #,body-exp))) -(module+ test - (br:define-cases #'op - [#'(_ "+") #''got-plus] - [#'(_ arg) #''got-something-else]) - (check-equal? (op "+") 'got-plus) - (check-equal? (op 42) 'got-something-else) - - (br:define-cases f - [(_ arg) (add1 arg)] - [(_ arg1 arg2) (+ arg1 arg2)]) +(module+ test + (require rackunit racket/port) + (parameterize ([current-output-port (open-output-nowhere)]) + (check-equal? (let () + (br:debug-define #'(foo X Y Z) + #'(apply + (list X Y Z))) + (foo 1 2 3)) 6) + (check-equal? (let () + (br:debug-define #'(foo X ...) #'(apply * (list X ...))) + (foo 10 11 12)) 1320))) - (check-equal? (f 42) 43) - (check-equal? (f 42 5) 47)) (define-syntax-rule (br:define+provide arg ...) (define+provide arg ...)) - diff --git a/beautiful-racket/br/demo/basic/expander.rkt b/beautiful-racket/br/demo/basic/expander.rkt index 24c5647..2830953 100644 --- a/beautiful-racket/br/demo/basic/expander.rkt +++ b/beautiful-racket/br/demo/basic/expander.rkt @@ -3,7 +3,10 @@ (rename-out [basic-module-begin #%module-begin]) (rename-out [basic-top #%top]) (all-defined-out)) -(require br/stxparam) +(require br/stxparam (for-syntax br/datum)) + +; BASIC implementation details +; http://www.atariarchives.org/basicgames/showpage.php?page=i12 (define-language-variables [A 0][B 0][C 0][D 0][E 0][F 0][G 0][H 0][I 0][J 0][K 0][L 0][M 0][N 0][O 0][P 0][Q 0][R 0][S 0][T 0][U 0][V 0][W 0][X 0][Y 0][Z 0][A$ ""][B$ ""][C$ ""][D$ ""][E$ ""][F$ ""][G$ ""][H$ ""][I$ ""][J$ ""][K$ ""][L$ ""][M$ ""][N$ ""][O$ ""][P$ ""][Q$ ""][R$ ""][S$ ""][T$ ""][U$ ""][V$ ""][W$ ""][X$ ""][Y$ ""][Z$ ""]) @@ -36,16 +39,19 @@ (exn:line-not-found (format "line number ~a not found in program" ln) (current-continuation-marks))))) - (void (with-handlers ([exn:program-end? (λ (exn) (void))]) - (for/fold ([program-counter 0]) - ([i (in-naturals)] - #:break (= program-counter (vector-length program-lines))) - (match-define (cons line-number proc) - (vector-ref program-lines program-counter)) - (define maybe-jump-number (and proc (proc))) - (if (number? maybe-jump-number) - (line-number->index maybe-jump-number) - (add1 program-counter)))))) + (with-handlers ([exn:program-end? (λ _ (void))]) + (for/fold ([program-counter 0]) + ([i (in-naturals)]) + (cond + [(= program-counter (vector-length program-lines)) (basic:END)] + [else + (match-define (cons line-number proc) + (vector-ref program-lines program-counter)) + (define maybe-jump-number (and proc (proc))) + (if (number? maybe-jump-number) + (line-number->index maybe-jump-number) + (add1 program-counter))]))) + (void)) (define #'(cr-line ARG ...) #'(begin ARG ...)) @@ -53,7 +59,7 @@ (define current-return-stack (make-parameter empty)) (define-cases #'line - [#'(_ NUMBER (STATEMENT "GOSUB" WHERE)) + [#'(_ NUMBER (statement-list (statement "GOSUB" WHERE))) #'(cons NUMBER (λ _ (let ([return-stack (current-return-stack)]) @@ -61,16 +67,24 @@ [(or (empty? return-stack) (not (= NUMBER (car return-stack)))) (current-return-stack (cons NUMBER (current-return-stack))) - (GOTO WHERE)] + (basic:GOTO WHERE)] [else (current-return-stack (cdr (current-return-stack)))]))))] - [#'(_ NUMBER STATEMENT ...) #'(cons NUMBER (λ _ STATEMENT ...))]) + [#'(_ NUMBER STATEMENT-LIST) #'(cons NUMBER (λ _ STATEMENT-LIST))]) +(define-cases #'statement-list + [#'(_ STATEMENT) #'(begin STATEMENT)] + [#'(_ STATEMENT ":" STATEMENT-LIST) #'(begin STATEMENT STATEMENT-LIST)]) (define-cases #'statement [#'(statement ID "=" EXPR) #'(set! ID EXPR)] - [#'(statement PROC ARG ...) #'(PROC ARG ...)]) - -(define-cases #'IF + ;[#'(statement "PRINT" ARG ...) #'(print ARG ...)] + ;[#'(statement "RETURN" ARG ...) #'(return ARG ...)] + ;[#'(statement "END" ARG ...) #'(end ARG ...)] + [#'(statement PROC-STRING ARG ...) + (inject-syntax ([#'PROC-ID (format-datum "basic:~a" #'PROC-STRING)]) + #'(PROC-ID ARG ...))]) + +(define-cases #'basic:IF [#'(_ COND "THEN" TRUE-RESULT "ELSE" FALSE-RESULT) #'(if (true? COND) TRUE-RESULT @@ -85,72 +99,65 @@ [#'(value ID-OR-DATUM) #'ID-OR-DATUM]) (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-cases #'expr - [#'(_ LEXPR "AND" REXPR) - #'(if (and (true? LEXPR) (true? REXPR)) 1 0)] - [#'(_ LEXPR "OR" REXPR) - #'(if (or (true? LEXPR) (true? REXPR)) 1 0)] - [#'(_ EXPR) #'EXPR]) + [#'(_ COMP-EXPR "AND" EXPR) #'(basic:and COMP-EXPR EXPR)] + [#'(_ COMP-EXPR "OR" EXPR) #'(basic:or COMP-EXPR EXPR)] + [#'(_ COMP-EXPR) #'COMP-EXPR]) (define-cases #'comp-expr - [#'(_ lexpr "=" rexpr) #'(comp-expr lexpr equal? rexpr)] ; special case because = is overloaded - [#'(_ lexpr op rexpr) #'(if (op lexpr rexpr) 1 0)] + [#'(_ 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)))] [#'(_ expr) #'expr]) -(define (<> lexpr rexpr) (not (equal? lexpr rexpr))) -(provide < > <= >= <>) +(define <> (compose1 not equal?)) -(define-cases sum - [(_ term op sum) (op term sum)] - [(_ term) term]) -(provide - +) +(define-cases #'sum + [#'(_ term "+" sum) #'(+ term sum)] + [#'(_ term "-" sum) #'(- term sum)] + [#'(_ term) #'term]) -(define-cases product - [(_ factor op product) (op factor product)] - [(_ factor) factor]) -(provide * /) +(define-cases #'product + [#'(_ factor "*" product) #'(* factor product)] + [#'(_ factor "/" product) #'(/ factor product)] + [#'(_ factor) #'factor]) (define print-list list) -(define (PRINT args) +(define (basic:PRINT args) (match args [(list) (displayln "")] [(list print-list-item ... ";" pl) (begin (for-each display print-list-item) - (display " ") - (PRINT pl))] - [(list print-list-item ... ";") (begin - (for-each display print-list-item) - (display " "))] + (print pl))] + [(list print-list-item ... ";") (for-each display print-list-item)] [(list print-list-item ...) (for-each displayln print-list-item)])) (define (TAB num) (make-string num #\space)) -(define #'(INT EXPR ...) #'(inexact->exact (round (expr EXPR ...)))) +(define #'(INT EXPR ...) #'(inexact->exact (truncate (expr EXPR ...)))) (define (SIN num) (sin num)) (define (ABS num) (inexact->exact (abs num))) (define (RND num) (* (random) num)) -(define-cases #'INPUT +(define-cases #'basic:INPUT [#'(_ PRINT-LIST ";" ID) #'(begin - (PRINT (append PRINT-LIST (list ";"))) - (INPUT ID))] + (basic:PRINT (append PRINT-LIST (list ";"))) + (basic:INPUT ID))] [#'(_ ID) #'(set! ID (let* ([str (read-line)] [num (string->number str)]) (if num num str)))]) -(define (GOTO where) - where) +(define (basic:GOTO where) where) -(define (RETURN) - (car (current-return-stack))) +(define (basic:RETURN) (car (current-return-stack))) (struct exn:program-end exn:fail ()) -(define (END) +(define (basic:END) (raise (exn:program-end "program ended" (current-continuation-marks)))) - - -(define (comment . args) void) diff --git a/beautiful-racket/br/demo/basic/parser.rkt b/beautiful-racket/br/demo/basic/parser.rkt index 3634c1d..421dcad 100644 --- a/beautiful-racket/br/demo/basic/parser.rkt +++ b/beautiful-racket/br/demo/basic/parser.rkt @@ -1,21 +1,20 @@ #lang ragg ;; recursive rules destucture easily in the expander -program : [line [CR line]*] +program : [CR]* [line [CR line]*] [CR]* -line: INTEGER statement+ +line: NUMBER statement-list + +statement-list : statement [":" statement-list] statement : "END" -| "FOR" ID "=" expr "TO" expr ["STEP" expr] -| "GOSUB" INTEGER +| "GOSUB" NUMBER | "GOTO" expr -| "IF" expr "THEN" (statement | expr) ["ELSE" (statement | expr)]; change: add expr +| "IF" expr "THEN" (statement | expr) ["ELSE" (statement | expr)] | "INPUT" [print-list ";"] ID -| ["LET"] ID "=" expr ; change: make "LET" opt -| "NEXT" ID+ +| ID "=" expr ; change: make "LET" opt | "PRINT" print-list | "RETURN" -| REM-COMMENT print-list : [expr [";" [print-list]]] @@ -28,9 +27,7 @@ sum : product [("+" | "-") sum] product : value [("*" | "/") product] value : "(" expr ")" -| ID -| PROC "(" expr* ")" -| INTEGER +| ID ["(" expr* ")"] | STRING -| REAL +| NUMBER diff --git a/beautiful-racket/br/demo/basic/reader.rkt b/beautiful-racket/br/demo/basic/reader.rkt index 699e020..f48cba5 100644 --- a/beautiful-racket/br/demo/basic/reader.rkt +++ b/beautiful-racket/br/demo/basic/reader.rkt @@ -2,6 +2,5 @@ (require br/reader-utils "parser.rkt" "tokenizer.rkt") (define-read-and-read-syntax (source-path input-port) - (strip-context - #`(module bf-mod br/demo/basic/expander - #,(parse source-path (tokenize (open-input-string (string-trim (port->string input-port)))))))) + #`(module bf-mod br/demo/basic/expander + #,(parse source-path (tokenize input-port)))) diff --git a/beautiful-racket/br/demo/basic/tokenizer.rkt b/beautiful-racket/br/demo/basic/tokenizer.rkt index 41de900..ab0a086 100644 --- a/beautiful-racket/br/demo/basic/tokenizer.rkt +++ b/beautiful-racket/br/demo/basic/tokenizer.rkt @@ -5,34 +5,30 @@ racket/string) (provide tokenize) +(define-lex-abbrevs + (natural (repetition 1 +inf.0 numeric)) + (integer (:seq (:? "-") natural)) + (number (:seq integer (:? (:seq "." natural)))) + (quoted-string (:seq "\"" (repetition 0 +inf.0 (char-complement "\"")) "\""))) + (define (tokenize input-port) (define (next-token) (define get-token (lexer - [(:seq "REM" (repetition 1 +inf.0 (char-complement "\n"))) - (token 'REM-COMMENT (format-datum '(comment "~v") lexeme))] - [(repetition 1 +inf.0 "\n") (token 'CR "cr")] + [(eof) eof] + [(union #\tab #\space + (:seq number " REM" (repetition 1 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)] + [(:seq #\newline (repetition 0 +inf.0 whitespace)) (token 'CR "cr")] [(union "PRINT" "FOR" "TO" "STEP" "IF" "GOTO" "INPUT" "LET" "NEXT" "RETURN" - "CLEAR" "LIST" "RUN" "END") (string->symbol lexeme)] - [(union "THEN" "ELSE" "GOSUB") lexeme] - - ;; this only matches integers - [(repetition 1 +inf.0 numeric) (token 'INTEGER (string->number lexeme))] - [(repetition 1 +inf.0 (union "." numeric)) (token 'REAL (string->number lexeme))] - ;; things that get thrown out: pass through as strings, - ;; because they can be matched literally in macros. - ;; things that become identifiers: pass through as symbols, - ;; so they can get bound by the expander. - [(union "," ":") (token 'SEPARATOR lexeme #:skip? #t)] - [(union ";" "=" "(" ")") lexeme] - [(union "+" "-" "*" "/" - "<=" ">=" "<>" "><" "<" ">" "=" ) (string->symbol lexeme)] - [(union "RND" "INT" "TAB" "SIN" "ABS") (token 'PROC (string->symbol lexeme))] + "CLEAR" "LIST" "RUN" "END" + "THEN" "ELSE" "GOSUB" "AND" "OR" + ";" "=" "(" ")" "+" "-" "*" "/" + "<=" ">=" "<>" "><" "<" ">" "=" ":") lexeme] + [(union ",") (get-token input-port)] + [number (token 'NUMBER (string->number lexeme))] [(:seq (repetition 1 +inf.0 upper-case) (:? "$")) (token 'ID (string->symbol lexeme))] [upper-case (token 'UPPERCASE (string->symbol lexeme))] - [whitespace (token 'WHITESPACE lexeme #:skip? #t)] - [(:seq "\"" (complement (:: any-string "\"" any-string)) "\"") (token 'STRING (string-trim lexeme "\""))] - [(eof) eof])) + [quoted-string (token 'STRING (string-trim lexeme "\""))])) (get-token input-port)) next-token)