111 lines
2.8 KiB
Racket
111 lines
2.8 KiB
Racket
(module my-macros mzscheme
|
|
|
|
(require-for-syntax mzlib/list)
|
|
|
|
;;;;;;;;;;
|
|
;;
|
|
;; paul graham's [ _ ] macro
|
|
;;
|
|
;;;;;;;;;;
|
|
|
|
(provide lx)
|
|
|
|
(define-syntax (lx stx)
|
|
(syntax-case stx ()
|
|
[(lx term)
|
|
(with-syntax ([binder (datum->syntax-object (syntax term) `_)])
|
|
(syntax (lambda (binder) term)))]))
|
|
|
|
|
|
|
|
;;;;;;;;;;
|
|
;;
|
|
;; ccond implementation
|
|
;;
|
|
;;;;;;;;;;
|
|
|
|
(provide ccond)
|
|
|
|
(define-syntax (ccond stx)
|
|
(syntax-case stx ()
|
|
[(_ (question answer) ...)
|
|
(syntax
|
|
(cond
|
|
(question answer) ...
|
|
(else (error 'ccond "fell off end of cond expression"))))]))
|
|
|
|
|
|
|
|
;;;;;;;;;;
|
|
;;
|
|
;; 2vals implementation
|
|
;;
|
|
;;;;;;;;;;
|
|
|
|
|
|
;; honestly, match-let* supersedes all of this, if I ever have time to redo it...
|
|
|
|
(provide 2vals let*-2vals 2vals-first 2vals-second 2vals-map apply-to-first-of-2vals)
|
|
|
|
(define 2vals vector)
|
|
|
|
(define-syntax (let*-2vals stx)
|
|
(syntax-case stx (let*-2vals)
|
|
[(let*-2vals () . bodies)
|
|
(syntax/loc stx (begin . bodies))]
|
|
[(let*-2vals ([(id-a id-b) rhs] binding ...) . bodies) ; 2 values in a vector
|
|
(syntax/loc stx (let* ([_a rhs] [id-a (vector-ref _a 0)] [id-b (vector-ref _a 1)])
|
|
(let*-2vals (binding ...) . bodies)))]
|
|
[(let*-2vals ([id-a rhs] binding ...) . bodies) ; just 1 value
|
|
(quasisyntax/loc stx (let* ([id-a rhs])
|
|
#,(syntax/loc stx (let*-2vals (binding ...) . bodies))))]))
|
|
|
|
(define-syntax (2vals-first stx)
|
|
(syntax-case stx (2vals-first)
|
|
[(2vals-first a)
|
|
(syntax (vector-ref a 0))]))
|
|
|
|
(define-syntax (2vals-second stx)
|
|
(syntax-case stx (2vals-second)
|
|
[(2vals-second a)
|
|
(syntax (vector-ref a 1))]))
|
|
|
|
(define (apply-to-first-of-2vals proc 2vals)
|
|
(vector (proc (vector-ref 2vals 0))
|
|
(vector-ref 2vals 1)))
|
|
|
|
; 2vals-map : (('a -> (2vals 'b 'c)) ('a list)) -> (2vals ('b list) ('c list))
|
|
; dual-map is like map, only for a procedure that returns (values a b), and its
|
|
; result is (values a-list b-list)... the contract specifies this more clearly.
|
|
|
|
(define (2vals-map f . lsts)
|
|
(if (null? (car lsts))
|
|
(2vals null null)
|
|
(let*-2vals ([(a b) (apply f (map car lsts))]
|
|
[(a-rest b-rest) (apply 2vals-map f (map cdr lsts))])
|
|
(2vals (cons a a-rest) (cons b b-rest))))))
|
|
|
|
; test cases
|
|
; (require my-macros)
|
|
;
|
|
;(= (2vals-first (2vals 3 4)) 3)
|
|
;(= (2vals-second (2vals 3 4)) 4)
|
|
;
|
|
;(=
|
|
; (let*-2vals
|
|
; ([a (2vals 3 4)]
|
|
; [(b c) a])
|
|
; a
|
|
; c)
|
|
; 4)
|
|
;
|
|
;(make-contract-checker my-type (lambda (x) (= x 3)))
|
|
;
|
|
;(contract-check-my-type? 3 'second-arg)
|
|
;;(contract-check-my-type? 14 'first-arg)
|
|
;
|
|
;((checked-lambda (x (y my-type) (z my-type))
|
|
; (+ x y z))
|
|
; 3 3 5)
|
|
;
|