source: project/misc-extn/trunk/misc-extn-control.scm @ 5438

Last change on this file since 5438 was 5438, checked in by Kon Lovett, 14 years ago

Added misc-extn extension element.

File size: 3.4 KB
Line 
1;;;; misc-extn-control.scm
2;;;; Kon Lovett, Jul '07
3
4;;; Control Forms
5
6(define-macro (me$typecase loc ?var ?expr ?forms)
7  `(let ([,?var ,?expr])
8     (cond
9       ,@(let ([make-type-pred
10                (lambda (typ)
11                  `(,(string->symbol (string-append (symbol->string typ) "?")) ,?var))])
12            (let loop ([forms ?forms] [lst '()])
13              (if (null? forms)
14                (reverse lst)
15                (let ([tcase (car forms)])
16                  (if (pair? tcase)
17                    (let ([typ (car tcase)])
18                      (loop
19                        (cdr forms)
20                        (cons
21                          (cons
22                            (cond
23                              [(eq? 'else typ)
24                                'else]
25                              [(symbol? typ)
26                                (make-type-pred typ)]
27                              [(pair? typ)
28                                `(or ,@(map make-type-pred typ))]
29                              [else
30                                (syntax-error loc "invalid case" tcase)])
31                            (cdr tcase))
32                          lst)))
33                    (syntax-error loc "invalid case" tcase)))))))) )
34
35(define-macro (typecase ?expr . ?forms)
36  `(me$typecase typecase ,(gensym) ,?expr ,?forms) )
37
38(define-macro (typecase* ?expr . ?forms)
39  `(me$typecase typecase* it ,?expr ,?forms) )
40
41;; 'Unless' synonym
42
43(define-macro (whennot CONDITION . BODY)
44  `(unless ,CONDITION ,@BODY) )
45
46;; Exchange bindings of two variables
47
48(define-macro (swap-set! A B)
49  (let ([TMP-VAR (gensym "tmp")])
50    `(let ([,TMP-VAR ,A])
51      (set! ,A ,B)
52      (set! ,B ,TMP-VAR))))
53
54;; Parallel chained set
55
56(define-macro (fluid-set! . REST)
57  (let loop ([todo REST])
58    (let ([VAR (car todo)]
59          [VAL (cadr todo)])
60      (let ([todo (cddr todo)])
61        (if (null? todo)
62          `(set! ,VAR ,VAL)
63          (let ([TMP-VAR (gensym)])
64            `(let ([,TMP-VAR ,VAL])
65              ,(loop todo)
66              (set! ,VAR ,TMP-VAR) ) ) ) ) ) ) )
67
68;; Serial chained set (CL SETQ like)
69
70(define-macro (stiff-set! . REST)
71  `(begin
72    ,@(let loop ([todo REST] [lst '()])
73      (if (null? todo)
74        lst
75        (loop (cddr todo) (cons `(set! ,(car todo) ,(cadr todo)) lst)) ) ) ) )
76
77;; Assign the result of the operation on the variable to itself
78;; Like C var <op>= <args>
79
80(define-macro (set!/op VAR OPER . REST)
81  `(set! ,VAR
82    (,OPER
83      ,@(let loop ([iargs REST] [oargs '()])
84          (if (null? iargs)
85            (cons VAR REST)
86            (let ([arg (car iargs)]
87                  [todo (cdr iargs)])
88              (if (eq? '<> arg)
89                (append (reverse (cons VAR oargs)) todo)
90                (loop todo (cons arg oargs)) ) ) ) ) ) ) )
91
92;;
93
94(define-macro (hash-let VARS-AND-HASH . BODY)
95  (let ([VARS (car VARS-AND-HASH)]
96        [HASH (cadr VARS-AND-HASH)])
97    (let (
98        [GETTERS
99          (map
100            (lambda (VAR)
101              (if (pair? VAR)
102                (let ([KEY (cadr VAR)] [REST (cddr VAR)])
103                  (if (symbol? KEY)
104                     `(hash-table-ref ,HASH ',KEY ,@REST)
105                     `(hash-table-ref ,HASH ,KEY ,@REST)))
106                  `(hash-table-ref ,HASH ',VAR)))
107            VARS)]
108        [ARGS
109          (map
110            (lambda (VAR)
111              (or (and (pair? VAR) (car VAR)) VAR))
112            VARS)])
113      `((lambda ,ARGS ,@BODY) ,@GETTERS) ) ) )
Note: See TracBrowser for help on using the repository browser.