source: project/release/3/misc-extn/trunk/misc-extn-control.scm @ 10987

Last change on this file since 10987 was 9954, checked in by Kon Lovett, 13 years ago

Rel 3.1.1 w/ Explict use of SRFI 69.

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