pull/2/head
Matthew Butterick 8 years ago
parent adda7adb88
commit c1469ee195

@ -79,14 +79,14 @@
(raise exn))]) (raise exn))])
. STATEMENTS)))) . STATEMENTS))))
(define-macro statement (define-macro-cases statement
[(statement ID "=" EXPR) #'(basic:let ID EXPR)] [(statement ID "=" EXPR) #'(basic:let ID EXPR)]
[(statement PROC-NAME . ARGS) [(statement PROC-NAME . ARGS)
(with-pattern (with-pattern
([PROC-ID (prefix-id "basic:" #'PROC-NAME)]) ([PROC-ID (prefix-id "basic:" #'PROC-NAME)])
#'(PROC-ID . ARGS))]) #'(PROC-ID . ARGS))])
(define-macro basic:let (define-macro-cases basic:let
[(_ (id-expr ID) EXPR) [(_ (id-expr ID) EXPR)
#'(begin #'(begin
#;(displayln (format "setting ~a = ~a in ~a" 'ID EXPR (current-line))) #;(displayln (format "setting ~a = ~a in ~a" 'ID EXPR (current-line)))
@ -94,7 +94,7 @@
[(_ (id-expr ID DIM-IDX ...) EXPR) [(_ (id-expr ID DIM-IDX ...) EXPR)
#'(array-set! ID DIM-IDX ... EXPR)]) #'(array-set! ID DIM-IDX ... EXPR)])
(define-macro basic:if (define-macro-cases basic:if
[(_ COND-EXPR TRUE-EXPR FALSE-EXPR) [(_ COND-EXPR TRUE-EXPR FALSE-EXPR)
#'(if (true? COND-EXPR) #'(if (true? COND-EXPR)
TRUE-EXPR TRUE-EXPR
@ -109,7 +109,7 @@
(define (basic:and . args) (cond->int (andmap true? args))) (define (basic:and . args) (cond->int (andmap true? args)))
(define (basic:or . args) (cond->int (ormap true? args))) (define (basic:or . args) (cond->int (ormap true? args)))
(define-macro id-expr (define-macro-cases id-expr
[(_ ID) #'(cond [(_ ID) #'(cond
[(procedure? ID) (ID)] [(procedure? ID) (ID)]
[(array? ID) (array-ref ID (make-vector (array-rank ID) 0))] ; no subscript => zeroth element [(array? ID) (array-ref ID (make-vector (array-rank ID) 0))] ; no subscript => zeroth element
@ -119,12 +119,12 @@
[(array? ID) (array-ref ID EXPR0 EXPR ...)] [(array? ID) (array-ref ID EXPR0 EXPR ...)]
[else (error 'id-expr-confused)])]) [else (error 'id-expr-confused)])])
(define-macro expr (define-macro-cases expr
[(_ COMP-EXPR) #'COMP-EXPR] [(_ COMP-EXPR) #'COMP-EXPR]
[(_ COMP-EXPR "and" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)] [(_ COMP-EXPR "and" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)]
[(_ COMP-EXPR "or" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)]) [(_ COMP-EXPR "or" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)])
(define-macro comp-expr (define-macro-cases comp-expr
[(_ SUM) #'SUM] [(_ SUM) #'SUM]
[(_ SUM "=" COMP-EXPR) [(_ SUM "=" COMP-EXPR)
#'(cond->int (equal? SUM COMP-EXPR))] ; special case because `=` is overloaded in basic #'(cond->int (equal? SUM COMP-EXPR))] ; special case because `=` is overloaded in basic
@ -135,26 +135,26 @@
(define <> (compose1 not equal?)) (define <> (compose1 not equal?))
(define-macro sum (define-macro-cases sum
[(_ SUM) #'SUM] [(_ SUM) #'SUM]
[(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)] [(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)]
[(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)]) [(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)])
(define-macro product (define-macro-cases product
[(_ "-" VALUE) #'(- VALUE)] [(_ "-" VALUE) #'(- VALUE)]
[(_ VALUE) #'VALUE] [(_ VALUE) #'VALUE]
[(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)] [(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)]
[(_ PRODUCT "/" VALUE) #'(/ PRODUCT VALUE)]) [(_ PRODUCT "/" VALUE) #'(/ PRODUCT VALUE)])
(define-macro power (define-macro-cases power
[(_ BASE) #'BASE] [(_ BASE) #'BASE]
[(_ BASE POWER) #'(expt BASE POWER)]) [(_ BASE POWER) #'(expt BASE POWER)])
(define-macro number (define-macro-cases number
[(_ "-" NUM) #'(- NUM)] [(_ "-" NUM) #'(- NUM)]
[(_ NUM) #'NUM]) [(_ NUM) #'NUM])
(define-macro id-val (define-macro-cases id-val
[(_ "-" ID) #'(- ID)] [(_ "-" ID) #'(- ID)]
[(_ ID) #'ID]) [(_ ID) #'ID])
@ -194,7 +194,7 @@
(define (EXP num) (exp num)) (define (EXP num) (exp num))
(define (SQR num) (sqrt num)) (define (SQR num) (sqrt num))
(define-macro basic:input (define-macro-cases basic:input
[(_ (print-list . PL-ITEMS) ID ...) [(_ (print-list . PL-ITEMS) ID ...)
#'(begin #'(begin
(basic:print (append (print-list . PL-ITEMS) (list ";"))) (basic:print (append (print-list . PL-ITEMS) (list ";")))
@ -206,7 +206,7 @@
(define (basic:goto where) where) (define (basic:goto where) where)
(define-macro basic:on (define-macro-cases basic:on
[(_ TEST-EXPR "goto" OPTION ...) [(_ TEST-EXPR "goto" OPTION ...)
#'(basic:goto (list-ref (list OPTION ...) (sub1 TEST-EXPR)))] #'(basic:goto (list-ref (list OPTION ...) (sub1 TEST-EXPR)))]
[(_ TEST-EXPR "gosub" OPTION ...) [(_ TEST-EXPR "gosub" OPTION ...)
@ -239,7 +239,7 @@
(define cmp (if (< left right) <= >=)) (define cmp (if (< left right) <= >=))
(cmp left x right)) (cmp left x right))
(define-macro basic:for (define-macro-cases basic:for
[(_ VAR START-VALUE END-VALUE) [(_ VAR START-VALUE END-VALUE)
#'(basic:for VAR START-VALUE END-VALUE 1)] #'(basic:for VAR START-VALUE END-VALUE 1)]
[(_ VAR START-VALUE END-VALUE STEP-VALUE) [(_ VAR START-VALUE END-VALUE STEP-VALUE)

Loading…
Cancel
Save