You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
beautiful-racket/beautiful-racket-demo/scriptish-demo/expander.rkt

86 lines
2.2 KiB
Racket

5 years ago
#lang br
5 years ago
(require racket/stxparam)
5 years ago
(provide (all-defined-out)
#%top-interaction #%top
(rename-out [my-datum #%datum]))
5 years ago
5 years ago
(define-macro top #'#%module-begin)
5 years ago
5 years ago
(define-macro (my-datum . VAL)
(with-syntax ([NEW-VAL (let ([val (syntax->datum #'VAL)])
(if (and (integer? val)
(inexact? val))
(inexact->exact val)
val))])
#'(#%datum . NEW-VAL)))
5 years ago
(define-macro (var ID VAL) #'(define ID VAL))
5 years ago
(define (add/concat . xs)
(cond
[(andmap number? xs) (apply + xs)]
[(ormap string? xs) (string-join (map ~a xs) "")]))
5 years ago
(define-macro-cases add-or-sub
5 years ago
[(_ LEFT "+" RIGHT) #'(add/concat LEFT RIGHT)]
[(_ LEFT "-" RIGHT) #'(- LEFT RIGHT)]
[(_ OTHER) #'OTHER])
(define-macro-cases mult-or-div
[(_ LEFT "*" RIGHT) #'(* LEFT RIGHT)]
[(_ LEFT "/" RIGHT) #'(/ LEFT RIGHT)]
[(_ OTHER) #'OTHER])
5 years ago
(define-macro (object (K V) ...)
#'(make-hash (list (cons K V) ...)))
5 years ago
(define-syntax-parameter return
(λ (stx) (error 'not-parameterized)))
(define-macro (fun (ARG ...) STMT ...)
5 years ago
(syntax/loc caller-stx
(λ (ARG ...)
5 years ago
(let/cc return-cc
(syntax-parameterize ([return (make-rename-transformer #'return-cc)])
5 years ago
STMT ... (void))))))
5 years ago
5 years ago
(define (resolve-deref base . keys)
(for/fold ([val base])
([key (in-list keys)])
(cond
[(and
(hash? val)
(cond
[(hash-ref val key #f)]
[(hash-ref val (symbol->string key) #f)]
[else #f]))]
[else (error 'deref-failure)])))
5 years ago
5 years ago
(define-macro (deref (BASE KEY ...))
#'(resolve-deref BASE 'KEY ...))
5 years ago
5 years ago
(define-macro app #'#%app)
5 years ago
5 years ago
(define-macro-cases if
[(_ COND TSTMT ... "else" FSTMT ...) #'(cond
[COND TSTMT ...]
[else FSTMT ...])]
[(_ COND STMT ...) #'(when COND STMT ...)])
5 years ago
(define-macro-cases comparison
[(_ VAL) #'VAL]
5 years ago
[(_ L "==" R) #'(equal? L R)]
[(_ L "!=" R) #'(not (equal? L R))])
5 years ago
(define-macro (while COND STMT ...)
#'(let loop ()
(when COND
STMT ...
(loop))))
(define alert displayln)
(define-macro (increment ID)
#'(let ()
(set! ID (add1 ID))
ID))