1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
(define-module (util)
#:use-module (srfi srfi-1)
#:export (destructure-lambda let-multi fold-lists catch-let
for-each-in
define-quick-record define-quick-record!
mod! sort*)
#:replace (let*)
)
(define-public upstring->symbol (compose string->symbol string-upcase))
(define-public symbol-upcase (compose string->symbol string-upcase symbol->string))
(define-public symbol-downcase (compose string->symbol string-downcase symbol->string))
(define-syntax destructure-lambda
(syntax-rules ()
((_ expr-list body ...)
(lambda (expr)
(apply (lambda expr-list body ...) expr)))))
(define-syntax catch-let
(syntax-rules ()
((_ thunk ((type handler) ...))
(catch #t thunk
(lambda (err . args)
(case err
((type) (apply handler err args)) ...
(else (format #t "Unhandled error type ~a, rethrowing ~%" err)
(apply throw err args))))))))
;;; For-each with arguments in reverse order.
(define-syntax-rule (for-each-in lst proc)
(for-each proc lst))
;;; Helper macros to make define-quick-record better
(define (class-name symb) (symbol-append '< symb '>))
(define (constructor symb) (symbol-append 'make- symb))
(define (pred symb) (symbol-append symb '?))
(define (getter name symb) (symbol-append 'get- name '- symb))
(define* (setter name symb #:optional bang?)
(symbol-append 'set- name '- symb (if bang? '! (symbol))))
(define (%define-quick-record internal-define bang? name fields)
(let ((symb (gensym)))
`(begin (,internal-define ,(class-name name)
(,(constructor name) ,@fields)
,(pred name)
,@(map (lambda (f) `(,f ,(getter f symb) ,(setter f symb bang?)))
fields))
,@(map (lambda (f) `(define ,f (make-procedure-with-setter
,(getter f symb) ,(setter f symb bang?))))
fields))))
;;; Creates srfi-9 define{-immutable,}-record-type declations.
;;; Also creates srfi-17 accessor ((set! (access field) value))
(define-macro (define-quick-record name . fields)
(%define-quick-record '(@ (srfi srfi-9 gnu) define-immutable-record-type)
#f name fields))
(define-macro (define-quick-record! name . fields)
(%define-quick-record '(@ (srfi srfi-9) define-record-type)
#t name fields))
;;; Replace let* with a version that can bind from lists.
;;; Also supports SRFI-71 (extended let-syntax for multiple values)
;;; Example:
;; (let* ([a b (values 1 2)] ; SRFI-71
;; [(c d) '(3 4)] ; Let-list (mine)
;; [e 5]) ; Regular
;; (list e d c b a))
;; ;; => (5 4 3 2 1)
;;;
(define-syntax let*
(syntax-rules ()
;; Base case
[(_ () body ...)
(begin body ...)]
;; (let (((a b) '(1 2))) (list b a)) => (2 1)
[(_ (((k k* ...) list-value) rest ...)
body ...)
(apply (lambda (k k* ...)
(let* (rest ...)
body ...))
list-value)]
;; "Regular" case
[(_ ((k value) rest ...) body ...)
(let ((k value))
(let* (rest ...)
body ...))]
;; SRFI-71 let-values
[(_ ((k k* ... values) rest ...) body ...)
(call-with-values (lambda () values)
(lambda (k k* ...)
(let* (rest ...)
body ...)))]
))
;; Like set!, but applies a transformer on the already present value.
(define-syntax-rule (mod! field transform-proc)
(set! field (transform-proc field)))
(define-public (concat lists)
(apply append lists))
;;; This function borrowed from web-ics (calendar util)
(define* (sort* items comperator #:optional (get identity))
"A sort function more in line with how python's sorted works"
(sort items (lambda (a b)
(comperator (get a)
(get b)))))
|
