diff --git a/math.rkt b/math.rkt index 98e10f1..633fa54 100644 --- a/math.rkt +++ b/math.rkt @@ -9,6 +9,12 @@ ;; but try to simplify arguments during expansion. expt: + + ;; -- + (for-syntax + nat/expand + int/expand + number/expand) ) (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 (syntax-parser [(_ f:id) @@ -47,15 +59,9 @@ (define-syntax (expt: stx) (syntax-parse stx - [(_ e1 e2) - #:with e1+ (expand-expr #'e1) - #:with e2+ (expand-expr #'e2) - (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+))))] + [(_ n1:number/expand n2:number/expand) + #:with n (expt (syntax-e #'n1.expanded) (syntax-e #'n2.expanded)) + (syntax/loc stx 'n)] [_:id (syntax/loc stx expt)] [(_ e* ...) @@ -87,7 +93,6 @@ ;; Watch for division-by-zero (if (and (zero? v) (eq? / op)) (division-by-zero stx) - ;(loop v (cons prev acc) (cdr e*)) (loop (op prev v) acc (cdr e*))) (loop v acc (cdr e*))) ;; else: save value in acc diff --git a/private/common.rkt b/private/common.rkt index ec75daf..4c275da 100644 --- a/private/common.rkt +++ b/private/common.rkt @@ -12,13 +12,25 @@ ;; If the argument is a syntax object representing a quoted datum `v`, ;; return `v`. ;; Otherwise, return #f. + + define-syntax-class/predicate + ;; (stx-> Identifier (-> Any Boolean) SyntaxClassDef) ) (require + syntax/parse (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) (local-expand stx 'expression '()))