suzanne.soy/trivial
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

[common] predicate -> syntax class

Browse Source
This commit is contained in:
ben 2016-03-03 13:29:35 -05:00
parent 98b03c91e3
commit fe1494f195
2 changed files with 27 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
math.rkt
View File

@ -9,6 +9,12 @@
;; but try to simplify arguments during expansion. ;; but try to simplify arguments during expansion.
expt: expt:
;; --
(for-syntax
nat/expand
int/expand
number/expand)
) )
(require (for-syntax (require (for-syntax
@ -22,6 +28,12 @@
;; ============================================================================= ;; =============================================================================
(begin-for-syntax
(define-syntax-class/predicate nat/expand exact-nonnegative-integer?)
(define-syntax-class/predicate int/expand integer?)
(define-syntax-class/predicate number/expand number?)
)
(define-syntax make-numeric-operator (define-syntax make-numeric-operator
(syntax-parser (syntax-parser
[(_ f:id) [(_ f:id)
@ -47,15 +59,9 @@
(define-syntax (expt: stx) (define-syntax (expt: stx)
(syntax-parse stx (syntax-parse stx
[(_ e1 e2) [(_ n1:number/expand n2:number/expand)
#:with e1+ (expand-expr #'e1) #:with n (expt (syntax-e #'n1.expanded) (syntax-e #'n2.expanded))
#:with e2+ (expand-expr #'e2) (syntax/loc stx 'n)]
(let ([n1 (quoted-stx-value? #'e1+)]
[n2 (quoted-stx-value? #'e2+)])
(if (and (number? n1)
(number? n2))
(quasisyntax/loc stx #,(expt n1 n2))
(syntax/loc stx (expt e1+ e2+))))]
[_:id [_:id
(syntax/loc stx expt)] (syntax/loc stx expt)]
[(_ e* ...) [(_ e* ...)
@ -87,7 +93,6 @@
;; Watch for division-by-zero ;; Watch for division-by-zero
(if (and (zero? v) (eq? / op)) (if (and (zero? v) (eq? / op))
(division-by-zero stx) (division-by-zero stx)
;(loop v (cons prev acc) (cdr e*))
(loop (op prev v) acc (cdr e*))) (loop (op prev v) acc (cdr e*)))
(loop v acc (cdr e*))) (loop v acc (cdr e*)))
;; else: save value in acc ;; else: save value in acc

12
private/common.rkt
View File

@ -12,13 +12,25 @@
;; If the argument is a syntax object representing a quoted datum `v`, ;; If the argument is a syntax object representing a quoted datum `v`,
;; return `v`. ;; return `v`.
;; Otherwise, return #f. ;; Otherwise, return #f.
define-syntax-class/predicate
;; (stx-> Identifier (-> Any Boolean) SyntaxClassDef)
) )
(require (require
syntax/parse
(for-template (only-in typed/racket/base quote))) (for-template (only-in typed/racket/base quote)))
;; ============================================================================= ;; =============================================================================
(define-syntax-rule (define-syntax-class/predicate id p?)
(define-syntax-class id
#:attributes (expanded)
(pattern e
#:with e+ (quoted-stx-value? (expand-expr #'e))
#:when (p? (syntax-e #'e+))
#:attr expanded #'e+)))
(define (expand-expr stx) (define (expand-expr stx)
(local-expand stx 'expression '())) (local-expand stx 'expression '()))