73 lines
2.4 KiB
Racket
73 lines
2.4 KiB
Racket
#lang racket/base
|
|
|
|
(require (for-syntax racket/base))
|
|
|
|
#;
|
|
(provide (all-defined-out))
|
|
|
|
(provide honu-transformer? make-honu-transformer)
|
|
|
|
(define-values (prop:honu-transformer honu-transformer? honu-transformer-ref)
|
|
(make-struct-type-property 'honu-transformer))
|
|
|
|
(define-values (struct:honu-trans make-honu-trans honu-trans? honu-trans-ref honu-trans-set!)
|
|
(make-struct-type 'honu-trans #f 1 0 #f
|
|
(list (list prop:honu-transformer #t))
|
|
(current-inspector) 0))
|
|
|
|
(define (make-honu-transformer proc)
|
|
(unless (and (procedure? proc)
|
|
(procedure-arity-includes? proc 1))
|
|
(raise-type-error
|
|
'define-honu-syntax
|
|
"procedure (arity 1)"
|
|
proc))
|
|
(make-honu-trans proc))
|
|
|
|
(provide (rename-out [prop:honu-operator? honu-operator?])
|
|
make-honu-operator
|
|
(rename-out [-honu-operator-ref honu-operator-ref]))
|
|
|
|
(define-values (prop:honu-operator prop:honu-operator? prop:honu-operator-ref)
|
|
(make-struct-type-property 'honu-operator))
|
|
|
|
#;
|
|
(provide honu-operator?)
|
|
|
|
(define operator-fields '(precedence assocation binary unary postfix?))
|
|
|
|
(define-values (struct:honu-operator -make-honu-operator honu-operator? -honu-operator-ref honu-operator-set!)
|
|
(make-struct-type 'honu-operator #f (length operator-fields) 0 #f
|
|
(list (list prop:honu-operator #t))
|
|
(current-inspector)
|
|
0))
|
|
|
|
(define (get n)
|
|
(lambda (operator)
|
|
(-honu-operator-ref operator n)))
|
|
|
|
(provide operator-precedence operator-association
|
|
operator-binary-transformer operator-unary-transformer
|
|
operator-postfix?)
|
|
|
|
(define operator-precedence (get 0))
|
|
(define operator-association (get 1))
|
|
(define operator-binary-transformer (get 2))
|
|
(define operator-unary-transformer (get 3))
|
|
(define operator-postfix? (get 4))
|
|
|
|
(define (make-honu-operator precedence associativity binary unary postfix?)
|
|
(when (and (procedure? binary)
|
|
(not (procedure-arity-includes? binary 2)))
|
|
(raise-type-error
|
|
'define-honu-operator/syntax
|
|
"procedure (arity 2)"
|
|
binary))
|
|
(when (and (procedure? unary)
|
|
(not (procedure-arity-includes? unary 1)))
|
|
(raise-type-error
|
|
'define-honu-operator/syntax
|
|
"procedure (arity 1)"
|
|
unary))
|
|
(-make-honu-operator precedence associativity binary unary postfix?))
|