Changeset 38044 in project for release/5/proceduralmacros/tags/2.0/tests/run.scm
 Timestamp:
 01/01/20 18:34:27 (8 weeks ago)
 Location:
 release/5/proceduralmacros/tags/2.0
 Files:

 1 edited
 1 copied
Legend:
 Unmodified
 Added
 Removed

release/5/proceduralmacros/tags/2.0/tests/run.scm
r37432 r38044 1 (import scheme (chicken base) 1 (import scheme 2 (chicken base) 3 checks 2 4 proceduralmacros 3 5 simpletests) 4 6 (importforsyntax (only proceduralmacros 5 with mappedsymbols7 withrenamedsymbols 6 8 macrorules 7 9 onceonly) 10 (only checks >>) 8 11 (only (chicken base) listof?) 9 12 (only bindings bind bindcase) 10 13 ) 11 14 12 (define Counter15 (define counter 13 16 (let ((n 0)) 14 17 (lambda () … … 16 19 n))) 17 20 18 (defineermacro (Square form % compare?) 19 (let ((x (cadr form))) 20 (onceonly (x) 21 `(* ,x ,x)))) 22 23 (defineermacrotransformer (Swap! form rename compare?) 24 (let ((x (cadr form)) (y (caddr form))) 25 (withmappedsymbols rename % (%tmp %let %set!) 26 `(,%let ((,%tmp ,x)) 27 (,%set! ,x ,y) 28 (,%set! ,y ,%tmp))))) 29 30 (defineermacro (Nif form % compare?) 31 (bind (_ xpr pos zer neg) 32 form 33 `(,%let ((,%result ,xpr)) 34 (,%cond 35 ((,%positive? ,%result) ,pos) 36 ((,%negative? ,%result) ,neg) 37 (,%else ,zer))))) 38 39 (defineirmacro (Vif form % compare?) 40 (bindcase form 41 ((_ test (key xpr . xprs)) 42 (cond 43 ((compare? key %then) 44 `(if ,test (begin ,xpr ,@xprs))) 45 ((compare? key %else) 46 `(if ,(not test) (begin ,xpr ,@xprs))) 47 (else 48 `(error 'Vif "syntaxerror")))) 49 ((_ test (key1 xpr . xprs) (key2 ypr . yprs)) 50 (cond 51 ((and (compare? key1 %then) 52 (compare? key2 %else)) 53 `(if ,test 54 (begin ,xpr ,@xprs) 55 (begin ,ypr ,@yprs))) 56 ((and (compare? key1 %else) 57 (compare? key2 %then)) 58 `(if ,test 59 (begin ,ypr ,@yprs) 60 (begin ,xpr ,@xprs))) 61 (else 62 `(error 'Vif "syntaxerror")))) 63 )) 64 65 (defineirmacro (Alambda form % compare?) 66 (bind (_ args xpr . xprs) form 67 `(letrec ((,%self (lambda ,args ,xpr ,@xprs))) 68 ,%self))) 69 70 (definetest (basicmacros?) 71 (= (Square (Counter)) 1) 72 (= (Square (Counter)) 4) 73 (= (Square (Counter)) 9) 74 75 (equal? (let ((x 'x) (y 'y)) 76 (Swap! x y) 77 (list x y)) 78 '(y x)) 79 80 (eq? (Nif 5 'pos 'zer 'neg) 'pos) 81 82 ;;; verbose if 83 (eq? (Vif (positive? 5) (then 'pos)) 'pos) 84 85 (equal? 86 (map (Alambda (n) 87 (if (zero? n) 88 1 89 (* n (self ( n 1))))) 90 '(1 2 3 4 5)) 91 '(1 2 6 24 120)) 92 ) 93 94 (definemacro (swap! x y) 95 `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp))) 96 97 (definemacro (nif xpr pos zer neg) 98 `(cond 99 ((positive? ,xpr) ,pos) 100 ((negative? ,xpr) ,neg) 101 (else ,zer))) 102 103 (definemacro (freeze xpr) 104 `(lambda () ,xpr)) 105 106 (definesyntax foo 107 (macrorules () 108 ((_ "foo" x) x) 109 ((_ #f x) `(list 'false)) 110 ((_ #f x) 'false) 111 ((_ a b) (where (a string?)) 112 `(list ,a ,b)) 113 ((_ a b) (where (a odd?)) 114 `(list ,a ,b)) 115 ((_ a b) a))) 116 117 (definemacro (bar #() x) 118 (where (x integer?)) 119 x) 120 121 (definemacro (qux #f) 122 #t) 123 124 (definemacro (in? what equ? . choices) 125 (let ((insym 'in)) 126 `(let ((,insym ,what)) 127 (or ,@(map (lambda (choice) `(,equ? ,insym ,choice)) 128 choices))))) 129 130 (definesyntax vif 131 (macrorules (then else) 132 ((_ test (then . xprs)) 133 `(if ,test 134 (begin ,@xprs))) 135 ((_ test (else . xprs)) 136 `(if ,(not test) 137 (begin ,@xprs))) 138 ((_ test (then . xprs) (else . yprs)) 139 `(if ,test 140 (begin ,@xprs) 141 (begin ,@yprs))))) 142 143 (define (oux) 144 (vif #t (then 'true))) 145 146 (define (pux) 147 (vif #f (else 'false))) 148 149 (definesyntax mycond 21 (print "\nWITHRENAMEDSYMBOLS\n") 22 (pe '(withrenamedsymbols (gensym %a %b %c) 'body)) 23 24 (print "\nONCEONLY\n") 25 (pe '(onceonly (x) 26 `(* ,x ,x))) 27 28 (print "\nMYCOND\n") 29 (pe ' 150 30 (macrorules (else =>) 151 31 ((_ (else xpr . xprs)) … … 160 40 (mycond ,@clauses)))) 161 41 ((_ (test)) 162 `(if #f #f)) 42 ;`(if #f #f)) 43 test) 163 44 ((_ (test) . clauses) 164 45 `(let ((tmp ,test)) … … 173 54 (mycond ,@clauses))) 174 55 )) 175 176 (definemacro (myletrec pairs . body) 177 (where (pairs (listof? pair?))) 178 (let ((vars (map car pairs)) 179 (vals (map cadr pairs)) 180 (aux (map (lambda (x) (gensym)) pairs))) 181 `(let ,(map (lambda (var) `(,var #f)) vars) 182 (let ,(map (lambda (a v) `(,a ,v)) aux vals) 183 ,@(map (lambda (v e) `(set! ,v ,e)) vars vals) 184 ,@body)))) 185 186 (definesyntax add 187 (macrorules () ((_ x y) 188 (where (x string?) (y string?)) 189 `(stringappend ,x ,y)) 190 (( _ x y) 191 (where (x integer?) (y integer?)) 192 `(+ ,x ,y)))) 193 194 (definesyntax alambda 195 (macrorules self () 196 ((_ args xpr . xprs) 197 `(letrec ((,self (lambda ,args ,xpr ,@xprs))) 198 ,self)))) 56 (newline) 57 58 (definemacro (square x) 59 (withexplicitrenaming (compare? %*) 60 (onceonly (x) 61 `(,%* ,x ,x)))) 62 63 (definemacro (wrongsquare x) 64 (withexplicitrenaming (compare? %*) 65 `(,%* ,x ,x))) 66 67 (definetest (macrohelpers?) 68 (equal? (withrenamedsymbols (identity %a %b %c) (list %a %b %c)) 69 '(a b c)) 70 (even? (wrongsquare (counter))) 71 (integer? (sqrt (square (counter)))) 72 ) 73 74 ;(macrohelpers?) 75 76 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 77 78 (definesyntax mycond 79 (macrorules (else =>) 80 ((_ (else xpr . xprs)) 81 `(begin ,xpr ,@xprs)) 82 ((_ (test => xpr)) 83 `(let ((tmp ,test)) 84 (if tmp (,xpr tmp)))) 85 ((_ (test => xpr) . clauses) 86 `(let ((tmp ,test)) 87 (if tmp 88 (,xpr tmp) 89 (mycond ,@clauses)))) 90 ((_ (test)) 91 ;`(if #f #f)) 92 test) 93 ((_ (test) . clauses) 94 `(let ((tmp ,test)) 95 (if tmp 96 tmp 97 (mycond ,@clauses)))) 98 ((_ (test xpr . xprs)) 99 `(if ,test (begin ,xpr ,@xprs))) 100 ((_ (test xpr . xprs) . clauses) 101 `(if ,test 102 (begin ,xpr ,@xprs) 103 (mycond ,@clauses))) 104 )) 105 106 (definesyntax vif 107 (macrorules (then else) 108 ((_ test (then xpr . xprs)) 109 `(if ,test 110 (begin ,xpr ,@xprs))) 111 ((_ test (else xpr . xprs)) 112 `(if ,(not test) 113 (begin ,xpr ,@xprs))) 114 ((_ test (then xpr . xprs) (else ypr . yprs)) 115 `(if ,test 116 (begin ,xpr ,@xprs) 117 (begin ,ypr ,@yprs))))) 199 118 200 119 (definesyntax aif … … 207 126 (if ,it ,consequent ,alternative))))) 208 127 209 (define (mist x) 210 (aif ((alambda (n) (if (zero? n) 1 (* n (self ( n 1))))) x) it)) 211 212 (define counter ; used for sideeffects 213 (let ((state 0)) 214 (lambda () 215 (set! state (+ state 1)) 216 state))) 217 218 (definemacro (square x) ; wrong without onceonly 219 (onceonly (x) 220 `(* ,x ,x))) 221 222 (definesyntax add2 223 (let ((id (lambda (n) n))) 224 (macrorules () 225 ((_ x) 226 `(+ ,(id x) 2)) 227 ((_ x y) 228 `(+ ,(id x) ,(id y) 2)) 229 ))) 230 231 (definemacro (for (var start end) . body) 232 (onceonly (start end) 233 `(do ((,var ,start (add1 ,var))) 234 ((= ,var ,end)) 235 ,@body))) 236 237 (definetest (proceduralmacros?) 238 (equal? (let ((x 'x) (y 'y)) 239 (swap! x y) 240 (list x y)) 241 '(y x)) 242 243 (eq? (nif 2 'positive 'zero 'negative) 'positive) 244 245 (= ((freeze 5)) 5) 246 247 (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y)) 248 '(y x)) 249 128 (definesyntax alambda 129 (macrorules self () 130 ((_ args xpr . xprs) 131 `(letrec ((,self (lambda ,args ,xpr ,@xprs))) 132 ,self)))) 133 134 (definesyntax foo 135 (macrorules () 136 ((_ "foo" x) x) 137 ((_ #f x) `(list 'false)) 138 ((_ #f x) 'false) 139 ((_ a b) (>> a string?) 140 `(list ,a ,b)) 141 ((_ a b) (>> a odd?) 142 `(list ,a ,b)) 143 ((_ a b) a))) 144 145 (definesyntax add 146 (macrorules () 147 ((_ x y) 148 (>> x string?) 149 (>> y string?) 150 `(stringappend ,x ,y)) 151 (( _ x y) 152 (>> x integer?) 153 (>> y integer?) 154 `(+ ,x ,y)))) 155 156 (define x 5) 157 158 (definetest (macrorules?) 159 (= x 5) 160 (= (aif (<< x odd?) it) 5) 161 (eq? (vif (odd? x) (then 'odd) (else 'even)) 'odd) 162 (= ((alambda (n) (if (= n 1) 1 (* n (self ( n 1))))) 5) 163 120) 250 164 "LITERALS" 251 165 (= (foo "foo" 1) 1) … … 254 168 (equal? (foo 1 2) '(1 2)) 255 169 (= (foo 2 3) 2) 256 257 (= (bar #() 5) 5)258 259 (qux #f)260 261 "IN?"262 (in? 2 = 1 2 3)263 (not (in? 5 = 1 2 3))264 265 "VERBOSE IFS"266 (eq? (oux) 'true)267 (eq? (pux) 'false)268 269 170 "LOWLEVEL COND" 270 171 (mycond ((> 3 2))) … … 281 182 (not (mycond ((assv 'x `((a 1) (b 2) (C 3))) => cadr) 282 183 (else #f))) 283 184 "FENDERS" 185 (= (add 1 2) 3) 186 (string=? (add "a" "b") "ab") 187 ) 188 189 ;(macrorules?) 190 191 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 192 193 (definemacro (myletrec pairs xpr . xprs) 194 ;(withimplicitrenaming (c?) 195 (>> pairs (listof? pair?)) 196 (let ((vars (map car pairs)) 197 (vals (map cadr pairs)) 198 (aux (map (lambda (x) (gensym)) pairs))) 199 `(let ,(map (lambda (var) `(,var #f)) vars) 200 (let ,(map (lambda (a v) `(,a ,v)) aux vals) 201 ,@(map (lambda (v e) `(set! ,v ,e)) vars vals) 202 ,xpr ,@xprs))));) 203 204 (definemacro (eswap! x y) 205 (withexplicitrenaming 206 (compare? %let %tmp %set!) 207 `(,%let ((,%tmp ,x)) 208 (,%set! ,x ,y) 209 (,%set! ,y ,%tmp)))) 210 211 (definemacro (iswap! x y) 212 (withimplicitrenaming (compare?) 213 `(let ((tmp ,x)) 214 (set! ,x ,y) 215 (set! ,y tmp)))) 216 217 (definemacro (swap! x y) 218 `(let ((tmp ,x)) 219 (set! ,x ,y) 220 (set! ,y tmp))) 221 222 (definemacro (vvif test (then . xprs) (else . yprs)) 223 (withexplicitrenaming (compare? %then %else %if %begin %error) 224 (if (and (compare? then %then) (compare? %else else)) 225 `(,%if ,test (,%begin ,@xprs) (,%begin ,@yprs)) 226 `(,%error 'vif "wrong keys" ',then ',else)))) 227 228 (definemacro (nif xpr pos zer neg) 229 (withexplicitrenaming 230 (c? %result %positive? %negative? %let %cond %else) 231 `(,%let ((,%result ,xpr)) 232 (,%cond 233 ((,%positive? ,%result) ,pos) 234 ((,%negative? ,%result) ,neg) 235 (,%else ,zer))))) 236 237 (definemacro (aalambda args xpr . xprs) 238 (withimplicitrenaming (compare? %self) 239 `(letrec ((,%self (lambda ,args ,xpr ,@xprs))) 240 ,%self))) 241 242 (definemacro (in what equ? . choices) 243 ;(withimplicitrenaming (c?) 244 (let ((insym 'in)) 245 `(let ((,insym ,what)) 246 (or ,@(map (lambda (choice) `(,equ? ,insym ,choice)) 247 choices)))));) 248 249 (definemacro (for (var start end) xpr . xprs) 250 ;(withimplicitrenaming (c?) 251 (onceonly (start end) 252 `(do ((,var ,start (add1 ,var))) 253 ((= ,var ,end)) 254 ,xpr ,@xprs)));) 255 256 (definemacro (freeze xpr) 257 `(lambda () ,xpr)) 258 259 (definetest (definemacro?) 260 (equal? (let ((x 'x) (y 'y)) 261 (eswap! x y) 262 (list x y)) 263 '(y x)) 264 (equal? (let ((x 'x) (y 'y)) 265 (iswap! x y) 266 (list x y)) 267 '(y x)) 268 (equal? (let ((x 'x) (y 'y)) 269 (swap! x y) 270 (list x y)) 271 '(y x)) 272 (= x 5) 273 (= ((aalambda (n) (if (= n 1) 1 (* n (self ( n 1))))) 5) 120) 274 (eq? (vvif (odd? x) (then 'odd) (else 'even)) 'odd) 275 (eq? (nif 2 'positive 'zero 'negative) 'positive) 276 (in 2 = 1 2 3) 277 (not (in 5 = 1 2 3)) 278 (= ((freeze 5)) 5) 279 (let ((lst '())) 280 (for (x 0 (counter)) (set! lst (cons x lst))) 281 (equal? lst '(3 2 1 0))) 284 282 "LETREC" 285 283 (equal? … … 288 286 (list (o? 95) (e? 95))) 289 287 '(#t #f)) 290 291 "GENERIC ADD" 292 (= (add 1 2) 3) 293 (string=? (add "x" "y") "xy") 294 295 "ANAPHORIC MACROS" 296 (equal? (map (alambda (n) (if (zero? n) 1 (* n (self ( n 1))))) '(1 2 3 4 5)) 297 '(1 2 6 24 120)) 298 299 (= (mist 5) 120) 300 301 "ONCEONLY" 302 (= (square (counter)) 1) 303 (= (square (counter)) 4) 304 (= (square (counter)) 9) 305 (let ((lst '())) 306 (for (x 0 (counter)) (set! lst (cons x lst))) 307 (equal? lst '(3 2 1 0))) 308 309 "LOCAL VARIABLES AVAILABLE IN EACH RULE" 310 (= (add2 5) 7) 311 (= (add2 5 7) 14) 312 313 314 "LET AND LETREC" 288 ) 289 290 ;(definemacro?) 291 292 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 293 294 (definetest (macrolet?) 295 (= (macrolet ( 296 ((first lst) 297 `(begin 298 (>> ,lst list?) 299 (car ,lst))) 300 ((rest lst) 301 `(begin 302 (>> ,lst list?) 303 (cdr ,lst))) 304 ) 305 (first (rest '(1 2 3)))) 306 2) 315 307 (= (macroletrec ( 316 ((sec lst) `(car (res ,lst))) 317 ((res lst) `(cdr ,lst)) 318 ) 319 (sec '(1 2 3))) 320 2) 321 (= (macrolet ( 322 ((fir lst) (where (lst list?)) `(car ,lst)) 323 ((res lst) (where (lst list?)) `(cdr ,lst)) 324 ) 325 (fir (res '(1 2 3)))) 308 ((second lst) `(car (rest ,lst))) 309 ((rest lst) `(cdr ,lst)) 310 ) 311 (second '(1 2 3))) 326 312 2) 327 313 (equal? 328 (macroletrec (((swap1 x y) 329 `(swap2 ,x ,y)) 330 ((swap2 x y) 331 (where (x symbol?) (y symbol?)) 332 `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))) 314 (macroletrec ( 315 ((swap1 x y) 316 `(swap2 ,x ,y)) 317 ((swap2 x y) 318 `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))) 319 ) 333 320 (let ((x 'x) (y 'y)) 334 321 (swap1 x y) … … 337 324 '(x y)) 338 325 (equal? 339 (macrolet (((swap1 x y) 340 `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))) 341 ((swap2 x y) 342 `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))) 326 (macrolet ( 327 ((swap1 x y) 328 `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))) 329 ((swap2 x y) 330 `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))) 331 ) 343 332 (let ((x 'x) (y 'y)) 344 333 (swap1 x y) … … 348 337 ) 349 338 350 (compoundtest (proceduralmacros) 351 (basicmacros?) 352 (proceduralmacros?) 353 ) ; compound test 339 ;(macrolet?) 340 341 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 342 343 (compoundtest (PROCEDURALMACROS) 344 (macrohelpers?) 345 (macrorules?) 346 (definemacro?) 347 (macrolet?) 348 ) 349
Note: See TracChangeset
for help on using the changeset viewer.