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

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

Rmvd dep procs. Updated doc.

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