Changeset 10970 in project for release/4/miscmacros
 Timestamp:
 06/01/08 01:28:47 (12 years ago)
 Location:
 release/4/miscmacros
 Files:

 2 edited
Legend:
 Unmodified
 Added
 Removed

release/4/miscmacros/miscmacros.scm
r6563 r10970 1 1 ;;;; miscmacros.scm 2 2 3 (module miscmacros 4 (modifylocation 5 let/cc until 6 repeat while repeat* if* while* 7 dotimes push! pop! inc! dec! exchange! modify! 8 begin0 9 defineoptionals defineparameter defineenum 10 ignorevalues ignoreerrors) 11 12 (import scheme) 13 ;; No effect  caller must import these manually. 14 ;; (import (only chicken 15 ;; when unless handleexceptions letoptionals makeparameter 16 ;; add1 sub1)) 17 3 18 ;;; Modify locations, Tlike: 4 19 5 (condexpand (syntaxcase 6 7 (definesyntax (modifylocation x) 8 (syntaxcase x () 9 ((_ (loc ...) proc) 10 (withsyntax (((tmp ...) (generatetemporaries #'(loc ...)))) 11 #'(let ((tmp loc) ...) 12 (proc (lambda () (tmp ...)) 13 (lambda (x) (set! (tmp ...) x)))) ) ) 14 ((_ loc proc) 15 #'(proc (lambda () loc) 16 (lambda (x) (set! loc x)) ) ) ) ) 17 18 )(else 19 20 (definemacro (modifylocation loc proc) 21 (let ((x (gensym))) 22 (if (atom? loc) 23 `(,proc (lambda () ,loc) 24 (lambda (,x) (set! ,loc ,x)) ) 25 (let ((tmps (map (lambda _ (gensym)) loc))) 26 `(let ,(map list tmps loc) 27 (,proc (lambda () ,tmps) 28 (lambda (,x) (set! ,tmps ,x))))) ) ) ) 29 30 ) ) 20 ;; syntaxcase implementation  unused 21 ;; (definesyntax (modifylocation x) 22 ;; (syntaxcase x () 23 ;; ((_ (loc ...) proc) 24 ;; (withsyntax (((tmp ...) (generatetemporaries #'(loc ...)))) 25 ;; #'(let ((tmp loc) ...) 26 ;; (proc (lambda () (tmp ...)) 27 ;; (lambda (x) (set! (tmp ...) x)))) ) ) 28 ;; ((_ loc proc) 29 ;; #'(proc (lambda () loc) 30 ;; (lambda (x) (set! loc x)) ) ) ) ) 31 32 (definesyntax modifylocation 33 (lambda (f r c) 34 (##sys#checksyntax 'modifylocation f '(_ _ _)) 35 (let ((loc (cadr f)) 36 (proc (caddr f)) 37 (%lambda (r 'lambda)) 38 (%set! (r 'set!)) 39 (%let (r 'let)) 40 (x (r 'x))) ; a temporary 41 (if (atom? loc) 42 `(,proc (,%lambda () ,loc) 43 (,%lambda (,x) (,%set! ,loc ,x))) 44 (let ((tmps (map (lambda _ (r (gensym))) loc))) 45 `(,%let ,(map list tmps loc) 46 (,proc (,%lambda () ,tmps) 47 (,%lambda (,x) (,%set! ,tmps ,x))))))))) 31 48 32 49 ;; evaluates body with an explicit exit continuation 33 50 ;; 34 (definemacro (let/cc K . BODY) 35 `(callwithcurrentcontinuation (lambda (,K) ,@BODY))) 51 (definesyntax let/cc 52 (syntaxrules () 53 ((let/cc k e0 e1 ...) 54 (callwithcurrentcontinuation 55 (lambda (k) e0 e1 ...))))) 36 56 37 57 ;; loop while expression false 38 58 ;; 39 (definemacro (until TEST . BODY) 40 (let ([LOOPTAG (gensym)]) 41 `(let ,LOOPTAG () 42 (unless ,TEST 43 ,@BODY 44 (,LOOPTAG))))) 45 46 ;; repeat body n times 47 ;; 48 (definemacro (repeat N . BODY) 49 (let ([CTRVAR (gensym)] 50 [LOOPTAG (gensym)]) 51 `(let ,LOOPTAG ([,CTRVAR ,N]) 52 (when (< 0 ,CTRVAR) 53 ,@BODY 54 (,LOOPTAG (sub1 ,CTRVAR)))))) 55 56 ;; repeat body n times, w/ countdown n bound to 'it' 57 ;; 58 (definemacro (repeat* N . BODY) 59 (let ([LOOPTAG (gensym)]) 60 `(let ,LOOPTAG ([it ,N]) 61 (when (< 0 it) 62 ,@BODY 63 (,LOOPTAG (sub1 it)))))) 64 65 ;; repeat body n times, w/ countup n bound to "var" 66 ;; 67 (definemacro (dotimes NV . BODY) 68 (if (and (list? NV) (eqv? 2 (length NV))) 69 (let ([V (car NV)] 70 [N (cadr NV)] 71 [NVAR (gensym)] 72 [LOOPTAG (gensym)]) 73 `(let ,LOOPTAG ([,V 0] [,NVAR ,N]) 74 (when (< ,V ,NVAR) 75 ,@BODY 76 (,LOOPTAG (add1 ,V) ,NVAR) ) ) ) 77 (syntaxerror 'dotimes "not a binding form" NV) ) ) 78 79 (definemacro (while x . xs) 80 (let ([var (gensym)]) 81 `(let ,var () 82 (when ,x (let () ,@xs (,var))) ) ) ) 83 84 (definemacro (while* x . xs) 85 (let ([LBL (gensym)]) 86 `(let ,LBL () 87 (if* ,x (let () ,@xs (,LBL))) ) ) ) 88 89 (definemacro (if* x y . z) 90 (let ([var (gensym)]) 91 `(let ([,var ,x]) 92 (if ,var 93 (let ([it ,var]) 94 ,y) 95 ,@z) ) ) ) 96 97 (definemacro (push! x y) 98 `(modifylocation 99 ,y 100 (lambda (get set) (set (cons ,x (get))) ) ) ) 101 102 (definemacro (pop! x) 103 (let ([var (gensym)] 104 (var2 (gensym)) ) 105 `(modifylocation 106 ,x 107 (lambda (get set) 108 (let* ([,var (get)] 109 (,var2 (car ,var)) ) 110 (set (cdr ,var)) 111 ,var2) ) ) ) ) 112 113 (definemacro (ignoreerrors . xs) 114 `(handleexceptions _ #f ,@xs) ) 115 116 (definemacro (begin0 x1 . xs) 117 (let ([var (gensym)]) 118 `(##sys#callwithvalues 119 (lambda () ,x1) 120 (lambda ,var 121 (begin ,@xs (apply ##sys#values ,var) ) ) ) ) ) 122 123 (definemacro (defineoptionals vars args) 124 `(begin 125 ,@(map (lambda (b) `(define ,(car b) #f)) vars) 126 ,(let ([aliases (map (lambda (b) (gensym (car b))) vars)]) 127 `(letoptionals ,args ,(map (lambda (b a) (cons a (cdr b))) vars aliases) 128 ,@(map (lambda (b a) `(set! ,(car b) ,a)) vars aliases) ) ) ) ) 129 130 (definemacro (defineparameter name . more) 131 (letoptionals* more ([init '(void)] more) 132 `(define ,name 133 (makeparameter ,init ,@more) ) ) ) 134 135 (definemacro (inc! v) 136 `(modifylocation 137 ,v 138 (lambda (get set) (set (add1 (get)))))) 139 140 (definemacro (dec! v) 141 `(modifylocation 142 ,v 143 (lambda (get set) (set (sub1 (get)))))) 144 145 (definemacro (exchange! x y) 146 (let ((tmp (gensym)) 147 (g1 (gensym)) 148 (g2 (gensym)) 149 (s1 (gensym)) 150 (s2 (gensym)) ) 151 `(modifylocation 152 ,x 153 (lambda (,g1 ,s1) 154 (modifylocation 155 ,y 156 (lambda (,g2 ,s2) 157 (let ((,tmp (,g1))) 158 (,s1 (,g2)) 159 (,s2 ,tmp) ) ) ) ) ) ) ) 160 161 (definemacro (modify! x proc) 162 (let ((get (gensym)) 163 (set (gensym)) ) 164 `(modifylocation 165 ,x 166 (lambda (,get ,set) (,set (,proc (,get)))))) ) 167 168 (definemacro (ignorevalues exp) 169 `(##sys#callwithvalues (lambda () ,exp) (lambda _ (##sys#void))) ) 170 59 (definesyntax until 60 (syntaxrules () 61 ((until test body ...) 62 (let loop () 63 (unless test 64 body ... 65 (loop)))))) 66 67 (definesyntax repeat 68 (syntaxrules () 69 ((repeat n body ...) 70 (let loop ((i n)) 71 (when (< 0 i) 72 body ... 73 (loop (sub1 i))))))) 74 75 (definesyntax while 76 (syntaxrules () 77 ((while test body ...) 78 (let loop () 79 (if test 80 (begin 81 body ... 82 (loop))))))) 83 84 ;; repeat body n times, w/ countdown n bound to 'it' hygienically 85 ;; (definesyntax repeat* 86 ;; (syntaxrules () 87 ;; ((repeat* (it n) body ...) 88 ;; (let loop ((it n)) 89 ;; (when (< 0 it) 90 ;; body ... 91 ;; (loop (sub1 it))))))) 92 93 ;; ;; if*: like if, but bind result of pred to 'it' hygienically 94 ;; (definesyntax if* 95 ;; (syntaxrules () 96 ;; ((if* (it pred) cons . alt) 97 ;; (let ((val pred)) 98 ;; (if val 99 ;; (let ((it val)) 100 ;; cons) 101 ;; . alt))))) 102 103 ;; ;; while*: like while, but bind result of test to 'it' hygienically 104 ;; (definesyntax while* 105 ;; (syntaxrules () 106 ;; ((while* (it test) body ...) 107 ;; (let loop () 108 ;; (if* (it test) 109 ;; (begin body ... (loop))))))) 110 111 ;; repeat*, if*, while*: versions which break hygiene to assign to 'it' 112 (definesyntax repeat* 113 (lambda (f r c) 114 (##sys#checksyntax 'repeat* f '(_ _ . _)) 115 (let ((loop (r 'loop)) 116 (n (cadr f)) 117 (body (cddr f))) 118 `(,(r 'let) ,loop ((it ,n)) 119 (,(r 'when) (,(r '<) 0 it) 120 ,@body 121 (,loop (,(r ') it 1))))))) 122 (definesyntax if* 123 (lambda (f r c) 124 (##sys#checksyntax 'if* f '(_ _ _ . _)) 125 (let ((x (cadr f)) 126 (y (caddr f)) 127 (z (cdddr f)) 128 (var (r 'var))) 129 `(,(r 'let) ((,var ,x)) 130 (,(r 'if) ,var 131 (,(r 'let) ((it ,var)) 132 ,y) 133 ,@z))))) 134 (definesyntax while* 135 (lambda (f r c) 136 (##sys#checksyntax 'while* f '(_ _ . _)) 137 (let ((test (cadr f)) 138 (body (cddr f))) 139 `(,(r 'let) ,(r 'loop) () 140 (,(r 'if*) ,test 141 (,(r 'begin) 142 ,@body 143 (,(r 'loop)) )))))) 144 145 ;; repeat body n times, w/ countup n bound to v 146 (definesyntax dotimes 147 (syntaxrules () 148 ((dotimes (v n) body ...) 149 (let loop ((v 0) (nv n)) 150 (if (< v nv) 151 (begin 152 body ... 153 (loop (add1 v) nv))))))) 154 155 (definesyntax push! 156 (syntaxrules () 157 ((push! x loc) 158 (modifylocation loc 159 (lambda (get set) 160 (set (cons x (get)))))))) 161 162 (definesyntax pop! 163 (syntaxrules () 164 ((pop! loc) 165 (modifylocation loc 166 (lambda (get set) 167 (let* ((var (get)) 168 (var2 (car var))) 169 (set (cdr var)) 170 var2)))))) 171 172 (definesyntax inc! 173 (syntaxrules () 174 ((inc! loc) 175 (modifylocation loc 176 (lambda (get set) 177 (set (add1 (get)))))))) 178 179 (definesyntax dec! 180 (syntaxrules () 181 ((dec! loc) 182 (modifylocation loc 183 (lambda (get set) 184 (set (sub1 (get)))))))) 185 186 (definesyntax exchange! 187 (syntaxrules () 188 ((exchange! x y) 189 (modifylocation 190 x 191 (lambda (get1 set1) 192 (modifylocation 193 y 194 (lambda (get2 set2) 195 (let ((tmp (get1))) 196 (set1 (get2)) 197 (set2 tmp))))))))) 198 199 (definesyntax modify! 200 (syntaxrules () 201 ((modify! loc proc) 202 (modifylocation loc 203 (lambda (get set) 204 (set (proc (get)))))))) 205 206 (definesyntax begin0 207 (syntaxrules () 208 ((_ e0 e1 ...) 209 (##sys#callwithvalues 210 (lambda () e0) 211 (lambda var 212 (begin 213 e1 ... 214 (apply ##sys#values var))))))) 215 216 (definesyntax defineoptionals 217 (lambda (f r c) 218 (let ((vars (cadr f)) 219 (args (caddr f))) 220 (##sys#checksyntax 'defineoptionals f '(_ #(#(_ 2 2) 1) _)) 221 `(,(r 'begin) 222 ,@(map (lambda (b) `(,(r 'define) ,(car b) #f)) vars) 223 ,(let ([aliases (map (lambda (b) (r (car b))) vars)]) 224 `(,(r 'letoptionals) ,args 225 ,(map (lambda (b a) (cons a (cdr b))) vars aliases) 226 ,@(map (lambda (b a) `(,(r 'set!) ,(car b) ,a)) vars aliases) ) ) ))) ) 227 228 (definesyntax defineparameter 229 (syntaxrules () 230 ((defineparameter name value guard) 231 (define name (makeparameter value guard))) 232 ((defineparameter name value) 233 (define name (makeparameter value))) 234 ((defineparameter name) 235 (define name (makeparameter (void)))))) 236 237 (definesyntax ignorevalues 238 (syntaxrules () 239 ((ignorevalues exp) 240 (##sys#callwithvalues (lambda () exp) 241 (lambda _ (##sys#void)))))) 242 243 (definesyntax ignoreerrors 244 (syntaxrules () 245 ((ignoreerrors body ...) 246 (handleexceptions _ #f body ...)))) 171 247 172 248 ;;; The following is courtesy of Alex Shinn: 173 249 174 (definemacro (defineenum >int >sym . vars) 175 (define (enumerate vars) 176 (let loop ((n 0) (enums '()) (vars vars)) 177 (if (null? vars) 178 (reverse enums) 179 (let ((n (if (pair? (car vars)) 180 (cadar vars) 181 n))) 182 (loop (+ n 1) 183 (cons n enums) 184 (cdr vars)))))) 185 (let ((ints (enumerate vars)) 186 (vars (map (lambda (v) (if (pair? v) (car v) v)) vars))) 187 `(begin 188 ,@(map (lambda (x i) `(defineconstant ,x ,i)) vars ints) 189 (define (,>int sym) 190 (case sym ,@(map (lambda (x i) `((,x) ,i)) vars ints) (else #f))) 191 (define (,>sym int) 192 (switch int ,@(map (lambda (x i) `(,i ',x)) vars ints) (else #f)))))) 250 (definesyntax defineenum 251 (lambda (f r c) 252 (define (enumerate vars) 253 (let loop ((n 0) (enums '()) (vars vars)) 254 (if (null? vars) 255 (reverse enums) 256 (let ((n (if (pair? (car vars)) 257 (cadar vars) 258 n))) 259 (loop (+ n 1) 260 (cons n enums) 261 (cdr vars)))))) 262 (##sys#checksyntax 'defineenum f '(_ _ _ . _)) 263 (let ((>int (cadr f)) 264 (>sym (caddr f)) 265 (vars (cdddr f))) 266 (let ((ints (enumerate vars)) 267 (vars (map (lambda (v) (if (pair? v) (car v) v)) vars))) 268 `(,(r 'begin) 269 ,@(map (lambda (x i) 270 `(,(r 'defineconstant) ,x ,i)) 271 vars ints) 272 (,(r 'define) (,>int ,(r 'sym)) 273 (,(r 'case) ,(r 'sym) 274 ,@(map (lambda (x i) 275 `((,x) ,i)) 276 vars ints) 277 (,(r 'else) #f))) 278 (,(r 'define) (,>sym ,(r 'int)) 279 (,(r 'case) ,(r 'int) 280 ,@(map (lambda (x i) 281 `((,i) ',x)) 282 vars ints) 283 (,(r 'else) #f))))))))) 
release/4/miscmacros/miscmacros.setup
r6565 r10970 1 (compile s d0 miscmacros.scm j miscmacros) 2 1 3 (installextension 'miscmacros 2 '("miscmacros. scm" "miscmacros.html")3 '((syntax) (version 2. 5) (documentation "miscmacros.html")))4 '("miscmacros.import.scm" "miscmacros.html") 5 '((syntax) (version 2.6b) (documentation "miscmacros.html"))) 4 6
Note: See TracChangeset
for help on using the changeset viewer.