~ chicken-core (chicken-5) /tests/dirty-macros.scm

   1; How to write dirty R5RS macros
   2; http://groups.google.com/groups?selm=87oflzcdwt.fsf%40radish.petrofsky.org
   3; How to write seemingly unhygienic macros using syntax-rules 
   4; Date: 2001-11-19 01:23:33 PST 
   5;
   6; $Id: dirty-macros.scm,v 1.10 2003/08/16 02:13:32 oleg Exp oleg $
   7
   8; Extract a colored identifier from a form
   9;    extract? SYMB BODY CONT-T CONT-F
  10; BODY is a form that may contain an occurence of an identifier that
  11; refers to the same binding occurrence as SYMB, perhaps with a different
  12; color. CONT-T and CONT-F are forms of the shape (K-HEAD K-IDL . K-ARGS)
  13; where K-IDL are K-ARGS are lists.
  14; If the extract? macro finds the identifier in question, it expands into
  15; CONT-T, to be more precise, into
  16;   (K-HEAD (extr-id . K-IDL) . K-ARGS)
  17; where extr-id is the extracted colored identifier. If the identifier
  18; SYMB does not occur in BODY at all, the extract macro expands into CONT-F,
  19; to be more precise,
  20;   (K-HEAD (SYMB . K-IDL) . K-ARGS)
  21
  22(define-syntax m-symbol?
  23  (syntax-rules ()
  24    ((_ maybe-symbol kt kf)
  25     (letrec-syntax
  26       ((ok
  27	  (syntax-rules ()
  28	    ((_) kt)))
  29	 (test
  30	  (syntax-rules ()
  31	    ((_ maybe-symbol) (ok))
  32	    ((_ x) kf))))
  33       (test abracadabra)))))
  34
  35(define-syntax m-symb-equal?
  36  (syntax-rules ()
  37    ((_ symb b kt kf)
  38	(let-syntax
  39	  ((symb (syntax-rules ()
  40		   ((_) kf)))
  41	   (ok (syntax-rules ()
  42		   ((_) kt))))
  43	  (let-syntax
  44	    ((test (syntax-rules ()
  45		     ((_ b) (symb))
  46		     ((_ x) kf))))
  47	    (test ok))))))
  48
  49(define-syntax extract?
  50  (syntax-rules ()
  51    ((_ symb body _cont-t _cont-f)
  52      (letrec-syntax
  53	((lp
  54           (syntax-rules (symb)
  55	      ((_ d symb stack (cont-head symb-l . cont-args) cont-f)
  56	       (cont-head (d . symb-l) . cont-args)) ; symb has occurred
  57	      ((_ d (x . y) stack . rest)   ; if body is a composite form,
  58	       (lp x x (y . stack) . rest)) ; look inside
  59	      ((_ d1 d2 () cont-t (cont-head  symb-l . cont-args))
  60	       (cont-head (symb . symb-l) . cont-args)) ; symb does not occur
  61	      ((_ d1 d2 (x . y) . rest)
  62	       (lp x x y . rest)))))
  63	(lp body body () _cont-t _cont-f)))))
  64
  65; (define-syntax extract?
  66;   (syntax-rules ()
  67;     ((_ symb body _cont-t _cont-f)
  68;       (letrec-syntax
  69; 	((tr
  70;            (syntax-rules ()
  71; 	      ((_ d (x . y) tail . rest)   ; if body is a composite form,
  72; 	       (tr x x (y . tail) . rest)) ; look inside
  73; 	      ((_ x y () (cont-head symb-l . cont-args) 
  74; 		 (cont-headf symb-lf . cont-argsf))
  75; 	       (m-symb-equal? symb y 
  76; 		 (cont-head (x . symb-l) . cont-args) ; symb has occurred
  77; 	       (cont-headf (symb . symb-lf) . cont-argsf)));symb does not occur
  78; 	     ((_ d1 d2 (x . y) (cont-head symb-l . cont-args) cont-f) 
  79; 	       (m-symb-equal? symb d2
  80; 		 (cont-head (d1 . symb-l) . cont-args) ; symb has occurred
  81; 		 (tr x x y (cont-head symb-l . cont-args) cont-f))))))
  82; 	(tr body body () _cont-t _cont-f)))))
  83
  84; Extract a colored identifier from a form
  85;    extract SYMB BODY CONT
  86; BODY is a form that may contain an occurence of an identifier that
  87; refers to the same binding occurrence as SYMB, perhaps with a different
  88; color. CONT is a form of the shape (K-HEAD K-IDL . K-ARGS)
  89; where K-IDL are K-ARGS are S-expressions representing lists or the
  90; empty list.
  91; The extract macro expands into
  92;   (K-HEAD (extr-id . K-IDL) . K-ARGS)
  93; where extr-id is the extracted colored identifier. If symbol SYMB does
  94; not occur in BODY at all, extr-id is identical to SYMB.
  95
  96
  97(define-syntax extract
  98  (syntax-rules ()
  99    ((_ symb body cont)
 100     (extract? symb body cont cont))))
 101
 102; Extract several colored identifiers from a form
 103;    extract* SYMB-L BODY CONT
 104; where SYMB-L is the list of symbols to extract, and BODY and CONT
 105; has the same meaning as in extract, see above.
 106; 
 107; The extract* macro expands into
 108;   (K-HEAD (extr-id-l . K-IDL) . K-ARGS)
 109; where extr-id-l is the list of extracted colored identifiers. The extraction
 110; itself is performed by the macro extract.
 111
 112(define-syntax extract*
 113  (syntax-rules ()
 114    ((_ (symb) body cont)      ; only one symbol: use extract to do the job
 115     (extract symb body cont))
 116    ((_ _symbs _body _cont)
 117     (letrec-syntax
 118	 ((ex-aux		; extract symbol-by-symbol
 119	   (syntax-rules ()
 120	     ((_ found-symbs () body cont)
 121	      (reverse () found-symbs cont))
 122	     ((_ found-symbs (symb . symb-others) body cont)
 123	      (extract symb body
 124		       (ex-aux found-symbs symb-others body cont)))
 125	     ))
 126	  (reverse		; reverse the list of extracted symbols
 127	   (syntax-rules ()     ; to match the order of SYMB-L
 128	     ((_ res () (cont-head () . cont-args))
 129	      (cont-head res . cont-args))
 130	     ((_ res (x . tail) cont)
 131	      (reverse (x . res) tail cont)))))
 132       (ex-aux () _symbs _body _cont)))))
 133
 134; Writing weakly referentially opaque macros
 135
 136; A binding-capturing macro with an explicit specification
 137; of the captured variable
 138(define-syntax m1-i
 139  (syntax-rules ()
 140    ((_ i val body) (let ((i val)) body))))
 141
 142(display
 143   (m1-i i 10 (* 1 i)))
 144(newline) ;==> 10
 145
 146; A dirty macro m1 that extracts i from its argument and expands
 147; into an invocation of m1-i:
 148
 149(define-syntax m1-dirty-v1
 150  (syntax-rules ()
 151    ((_ _val _body)
 152     (let-syntax
 153	 ((cont
 154	   (syntax-rules ()
 155	     ((_ (symb) val body) (let ((symb val)) body) ))))
 156       (extract i _body (cont () _val _body))))))
 157
 158(display
 159   (m1-dirty-v1 10 (* 1 i))
 160)
 161(newline)
 162
 163(display
 164   (m1-dirty-v1 10
 165     (m1-dirty-v1 20 (* 1 i)))
 166)
 167(newline)
 168
 169
 170; A macro that re-defines itself in its expansion
 171;  m1-dirty-v2 val body
 172; expands into
 173; (let ((i val)) body)
 174; and also re-defines itself in the scope of body.
 175
 176(define-syntax m1-dirty-v2
 177  (syntax-rules ()
 178    ((_ _val _body)
 179     (letrec-syntax
 180	 ((doit		    ; it's the continuation from extract*
 181	   (syntax-rules () ; myself-symb i-symb are colored ids extracted
 182	     ((_ (myself-symb i-symb) val body)      ; from the 'body'
 183	      (let ((i-symb val))  ; first bind the symbol i
 184		(letrec-syntax	   ; now re-define oneself
 185		    ((myself-symb
 186		      (syntax-rules ()
 187			((_ val__ body__)
 188			 (extract* (myself-symb i-symb) body__
 189				  (doit () val__ body__))))))
 190		  body))))))
 191       (extract* (m1-dirty-v2 i) _body
 192		 (doit () _val _body))))))
 193
 194(display "m1-dirty-v2")
 195(newline)
 196(display
 197   (m1-dirty-v2 10 (* 1 i))
 198)
 199(newline)
 200; => 10
 201
 202(display
 203   (m1-dirty-v2 10
 204     (m1-dirty-v2 20 
 205       (m1-dirty-v2 30 (* 1 i))))
 206)
 207(newline)
 208
 209(display
 210  (let ((i 1))
 211   (m1-dirty-v2 10 (* 1 i)))
 212)
 213(newline)
 214; => 1
 215
 216; A self-perpetuating smearing let
 217;   (mylet ((var init)) body)
 218; expands into
 219;   (let ((var init)) body')
 220; where body' is body wrapped into redefinitions of mylet
 221; and a macro m1-dirty-v3
 222
 223; This macro is closed (no free variables)
 224(define-syntax dirty-m-gen
 225  (syntax-rules ()
 226    ((_ name let-name _symb_ _body_)
 227     (let-syntax
 228	 ((name
 229	   (syntax-rules ()
 230	     ((_ _val _body)
 231	      (let-syntax
 232		  ((cont
 233		    (syntax-rules ()
 234		      ((_ (symb) val body) (let ((symb val)) body) ))))
 235		(extract _symb_ _body (cont () _val _body)))))))
 236       _body_))))
 237
 238; (define-syntax mylet
 239;   (syntax-rules ()
 240;     ((_ ((_var _init)) _body)
 241;      (letrec-syntax
 242; 	 ((doit		    ; it's the continuation from extract*
 243; 	   (syntax-rules () ; myself-symb etc. are extr. colored ids extracted
 244; 	     ((_ (myself-symb dirty-m-symb i-symb) ((var init)) body) 
 245; 	      (let ((var init))     ; first do the binding
 246; 		(letrec-syntax	    ; now re-define oneself
 247; 		    ((myself-symb
 248; 		      (syntax-rules ()
 249; 			((_ ((var__ init__)) body__)
 250; 			 (extract* (myself-symb dirty-m-symb i-symb)
 251; 				   (var__ body__)
 252; 				  (doit () ((var__ init__)) body__))))))
 253; 		  (dirty-m-gen      ; re-generate the dirty macro
 254; 		   dirty-m-symb myself-symb i-symb
 255; 		  body)))))))
 256;        (extract* (mylet m1-dirty-v3 i) (_var _body)
 257; 		 (doit () ((_var _init)) _body))))))
 258
 259;      (letrec-syntax 
 260;        ((ex
 261; 	 (syntax-rules ()
 262; 	   ((_ (mylet-symb mm-symb foo-symb) ((var init)) body)
 263; 	    (let ((var init))
 264; 	      (make-mm mm-symb foo-symb
 265; 		  (letrec-syntax 
 266; 		      ((mylet-symb
 267; 			(syntax-rules ()
 268; 			  ((_ ((var_ init_)) body_)
 269; 		       (extract* (mylet-symb mm-symb foo-symb) (var_ body_)
 270; 				  (ex () ((var_ init_)) body_))))))
 271; 		 body)))
 272; 	    ))))
 273;        (extract* (mylet mm foo) (_var _body)
 274; 		 (ex () ((_var _init)) _body))))))
 275
 276; (display "m1-dirty-v3")
 277; (newline)
 278; (display
 279;  (mylet ((i 1))
 280; 	(m1-dirty-v3 10 (* 1 i)))
 281; )
 282; (newline)
 283
 284; (display
 285;  (mylet ((i 1))
 286; 	(mylet ((i 10))
 287; 		     (m1-dirty-v3 20 (* 1 i))))
 288; )
 289; (newline)
 290
 291; (display
 292;  (mylet ((i 1))
 293; 	(m1-dirty-v3 10
 294; 		     (m1-dirty-v3 20 (* 1 i))))
 295; )
 296; (newline)
 297
 298
 299; A macro that generates a dirty macro:
 300;    m1-dirty BODY
 301; expands into a definition of a macro
 302;    NAME BODY
 303; which in turn expands into (let ((SYMB 10)) BODY) 
 304; such that the binding captures any free occurences of SYMB in BODY.
 305
 306; (define-syntax m1-dirty
 307;   (syntax-rules ()
 308;     ((_ _symb _body)
 309;      (let-syntax
 310; 	 ((doit
 311; 	   (syntax-rules ()
 312; 	     ((_ (symb) val body)
 313; 	      (let ((symb val)) body)))))
 314;        (extract _symb _body (doit () 10 _body))))))
 315
 316; Macro: make-mm NAME SYMB BODY
 317; In the scope of BODY, define a macro NAME that expands into a symbol SYMB
 318
 319(define-syntax make-mm
 320  (syntax-rules ()
 321    ((_ name symb body)
 322      (let-syntax 
 323	 ((name
 324	   (syntax-rules ()
 325	     ((_) symb))))
 326	body))))
 327
 328; (define-syntax mylet
 329;   (syntax-rules (foo)
 330;     ((_ ((var init)) body)
 331; 	(extract foo (var)
 332; 	 (make-mm-in ((var init)) body)))))
 333
 334; (mylet ((var init)) body)
 335; expands into
 336; (let ((var init)) body')
 337; where body' is the body wrapped in the re-definitions of mylet and macro mm.
 338
 339(define-syntax mylet
 340  (syntax-rules ()
 341    ((_ ((_var _init)) _body)
 342     (letrec-syntax 
 343       ((doit			; The continuation from extract*
 344	 (syntax-rules ()       ; mylet-symb, etc. are extracted from body
 345	   ((_ (mylet-symb mm-symb foo-symb) ((var init)) body)
 346	    (let ((var init))	; bind the 'var' first
 347	      (make-mm mm-symb foo-symb  ; now re-generate the macro mm
 348		  (letrec-syntax 
 349		      ((mylet-symb       ; and re-define myself
 350			(syntax-rules ()
 351			  ((_ ((var_ init_)) body_)
 352		       (extract* (mylet-symb mm-symb foo-symb) (var_ body_)
 353				  (doit () ((var_ init_)) body_))))))
 354		 body)))
 355	    ))))
 356       (extract* (mylet mm foo) (_var _body)
 357		 (doit () ((_var _init)) _body))))))
 358
 359(display "mylet")
 360(newline)
 361(define foo 1)
 362(display
 363 (mylet ((x 1)) (list (mm) x))
 364)
 365(newline)
 366
 367(display
 368 (mylet ((foo 2)) (list (mm) foo))
 369)
 370(newline)
 371
 372; ;(let ((foo 3)) (mylet ((foo 4)) (list foo (mm))))
 373;(mylet ((foo 2)) (mylet ((foo 3)) (list foo (mm))))
 374
 375(display
 376 (mylet ((foo 3)) (mylet ((foo 4)) (mylet ((foo 5)) (list foo (mm)))))
 377)
 378(newline)
 379
 380(display
 381 (mylet ((foo 3))
 382    (mylet ((thunk (lambda () (mm))))
 383     (mylet ((foo 4)) (list foo (mm) (thunk)))))
 384)
 385(newline)
 386
 387; The following are definitions of let, let* and letrec, straight out of R5RS.
 388; The only difference is that the definitions use custom-bound 
 389; let, let*, letrec and lambda identifiers, which we explicitly pass 
 390; to the macros in the first argument.
 391
 392(define-syntax glet		; let, straight out of R5RS
 393  (syntax-rules ()
 394    ((_ (let let* letrec lambda) ((name val) ...) body1 body2 ...)
 395     ((lambda (name ...) body1 body2 ...) val ...))
 396    ((_ (let let* letrec lambda) tag ((name val) ...) body1 body2 ...)
 397     ((letrec ((tag
 398		(lambda (name ...) body1 body2 ...))) tag) val ...))))
 399
 400(define-syntax glet*		; let*, straight out of R5RS
 401  (syntax-rules ()
 402    ((_ mynames () body1 body2 ...)
 403     (let () body1 body2 ...))
 404    ((_ (let let* letrec lambda)
 405	((name1 val1) (name2 val2) ...) body1 body2 ...)
 406     (let ((name1 val1)) (let* ((name2 val2) ...) body1 body2 ...)))))
 407
 408; A shorter implementations of letrec, see
 409; "Re: Widespread bug (arguably) in letrec when an initializer returns twice"
 410; comp.lang.scheme, 2001-05-21 10:30:34 PST and 2001-05-21 14:56:49 PST
 411; http://groups.google.com/groups?selm=7eb8ac3e.0105210930.21542605%40posting.google.com
 412; http://groups.google.com/groups?selm=87ae468j7x.fsf%40app.dial.idiom.com
 413
 414(define-syntax gletrec
 415  (syntax-rules ()
 416    ((_ (mlet let* letrec lambda) ((var init) ...) . body)
 417     (mlet ((var 'undefined) ...)
 418       (let ((temp (list init ...)))  ; the native let will do fine here
 419         (begin (begin (set! var (car temp)) (set! temp (cdr temp))) ...
 420         (let () . body)))))))
 421
 422; This macro defiles its body
 423; It re-defines all the let-forms and the lambda, and defines
 424; a non-hygienic macro 'mm'. Whenever any binding is introduced,
 425; the let-forms, the lambdas and 'mm' are redefined.
 426; The redefined lambda acts as if it were infected by a virus, which
 427; keeps spreading within lambda's body to infect other lambda's there.
 428
 429(define-syntax defile
 430  (syntax-rules ()
 431    ((_ dbody)
 432     (letrec-syntax
 433	 ((do-defile
 434	   (syntax-rules ()	; all the shadowed symbols
 435	     ((_ (let-symb let*-symb letrec-symb lambda-symb mm-symb foo-symb)
 436		 body-to-defile)
 437	      (letrec-syntax
 438		  ((let-symb		; R5RS definition of let
 439		    (syntax-rules ()
 440		      ((_ . args)
 441		       (glet (let-symb let*-symb letrec-symb lambda-symb)
 442			     . args))))
 443
 444		   (let*-symb		; Redefinition of let*
 445		    (syntax-rules ()
 446		      ((_ . args) 
 447		       (glet* (let-symb let*-symb letrec-symb lambda-symb) 
 448			      . args))))
 449
 450		   (letrec-symb		; Redefinition of letrec
 451		    (syntax-rules ()
 452		      ((_ . args) 
 453		       (gletrec (let-symb let*-symb letrec-symb lambda-symb) 
 454			      . args))))
 455		       
 456		   (lambda-symb         ; re-defined, infected lambda
 457		    (syntax-rules ()
 458		      ((_ _vars _body)
 459		       (letrec-syntax 
 460			   ((doit
 461			     (syntax-rules ()
 462			       ((_ (mylet-symb mylet*-symb myletrec-symb
 463					       mylambda-symb mymm-symb 
 464					       myfoo-symb) vars body)
 465				(lambda-native vars
 466				  (make-mm mymm-symb myfoo-symb
 467				    (do-defile	; proliferate in the body
 468				     (mylet-symb mylet*-symb myletrec-symb
 469						 mylambda-symb
 470						 mymm-symb myfoo-symb)
 471				     body))))))
 472			    (proliferate
 473			     (syntax-rules ()
 474			       ((_ dummy __vars __body)
 475				(extract* (let-symb let*-symb 
 476						    letrec-symb lambda-symb
 477						    mm-symb foo-symb)
 478					  (__vars __body)
 479					  (doit () __vars __body)))))
 480			    (stop-infection
 481			     (syntax-rules ()
 482			       ((_ dummy __vars __body)
 483				(lambda-native __vars __body))))
 484			    )
 485			 (extract? mm-symb _vars
 486			    ; true-continuation
 487			    (stop-infection () _vars _body)
 488			    ; false-cont
 489			    (proliferate () _vars _body))
 490			 ))))
 491
 492		   (lambda-native	; capture the native lambda
 493		    (syntax-rules ()
 494		      ((_ . args) (lambda . args))))
 495		   )
 496
 497		body-to-defile)))))
 498
 499       (extract* (let let* letrec lambda mm foo) dbody
 500		 (do-defile () dbody))
 501       ))))
 502
 503
 504;(mylet ((foo 2)) (mylet ((x 3)) (mylet ((foo 4)) (list (mm) foo))))
 505(display "defile")
 506(display "now.\n" (current-error-port))
 507(newline)
 508(defile
 509  (display
 510   (let ((foo 2)) (list (mm) foo))
 511   )
 512)
 513(newline)
 514; ==> (2 2)
 515
 516(defile
 517  (display
 518   (let ((foo 2)) (let ((foo 3)) (let ((foo 4)) (list (mm) foo))))
 519   )
 520)
 521(newline)
 522; ==> (4 4)
 523
 524(defile
 525  (display
 526   (let ((foo 2))
 527     (let ((foo 3) (bar (list (mm) foo)))
 528       (list foo (mm) bar)))
 529   )
 530)
 531(newline)
 532; ==> (3 3 (2 2)) 
 533
 534(defile
 535  (display
 536   (let ((foo 2))
 537     (list
 538      ((letrec ((bar (lambda () (list foo (mm))))
 539		(foo 3))
 540	bar))
 541      foo (mm)))))
 542(newline)
 543;==> ((3 3) 2 2) 
 544
 545(defile
 546  (display
 547   (let ((foo 2))
 548     (let foo ((flag #t) (lst (list foo (mm))))
 549       (if flag ((mm) #f (list lst lst)) lst)))))
 550(newline)
 551; ==> ((2 2) (2 2)) 
 552
 553(defile
 554  (display
 555  (let* ((foo 2) 
 556	 (i 3)
 557	 (foo 4) 
 558	 (ft (lambda () (mm))) ; will capture binding of foo to 4
 559	 (foo 5)
 560	 (ft1 (lambda (foo) (mm))) ; will  capture the arg of ft1
 561	 (foo 6))
 562    (list foo (mm) (ft) (ft1 7) '(mm))))
 563  )
 564(newline)
 565; ==> (6 6 4 7 (mm))
 566
 567; the use of (mm) (separately-defined macro) is equivalent to the use of variable foo -- 
 568; (define-macro (mm) foo) -- dirty macro
 569
 570
 571; Re-defining the global let
 572
 573(define-syntax dlet
 574  (syntax-rules ()
 575    ((_ new-let-symb . args) 
 576     ; just renaming of new-let-symbol with 'let'
 577     (let-syntax
 578	 ((ren 
 579	   (syntax-rules ()
 580	     ((_ list) (defile (let . args))))))
 581       (ren let1)))))
 582
 583
 584(display "dlet")
 585(newline)
 586(display
 587 (dlet list ((foo 2)) (list (mm) foo))
 588 )
 589
 590; (define-syntax old-let
 591;   (syntax-rules ()
 592;     ((_ . args) (let . args))))
 593; (define-syntax old-let*
 594;   (syntax-rules ()
 595;     ((_ . args) (let* . args))))
 596; (define-syntax old-letrec
 597;   (syntax-rules ()
 598;     ((_ . args) (letrec . args))))
 599; (define-syntax old-lambda
 600;   (syntax-rules ()
 601;     ((_ . args) (lambda . args))))
 602
 603; (define-syntax let
 604;    (syntax-rules ()
 605;      ((_ . args) (defile1 (glet (old-let old-let* old-letrec lambda) . args)))))
 606; ; (define-syntax let
 607; ;    (syntax-rules ()
 608; ;      ((_ . args) (defile1 (old-let . args)))))
 609
 610
 611; (define-syntax defile1
 612;   (syntax-rules ()
 613;     ((_ dbody)
 614;      (letrec-syntax
 615; 	 ((do-defile
 616; 	   (syntax-rules ()	; all the shadowed symbols
 617; 	     ((_ (let-symb let*-symb letrec-symb lambda-symb mm-symb foo-symb)
 618; 		 body-to-defile)
 619; 	      (letrec-syntax
 620; 		  ((let-symb		; R5RS definition of let
 621; 		    (syntax-rules ()
 622; 		      ((_ . args)
 623; 		       (glet (let-symb let*-symb letrec-symb lambda-symb)
 624; 			     . args))))
 625
 626; 		   (let*-symb		; Redefinition of let*
 627; 		    (syntax-rules ()
 628; 		      ((_ . args) 
 629; 		       (glet* (let-symb let*-symb letrec-symb lambda-symb) 
 630; 			      . args))))
 631
 632; 		   (letrec-symb		; Redefinition of letrec
 633; 		    (syntax-rules ()
 634; 		      ((_ . args) 
 635; 		       (gletrec (let-symb let*-symb letrec-symb lambda-symb) 
 636; 			      . args))))
 637		       
 638; 		   (lambda-symb         ; re-defined, infected lambda
 639; 		    (syntax-rules ()
 640; 		      ((_ _vars _body)
 641; 		       (letrec-syntax 
 642; 			   ((doit
 643; 			     (syntax-rules ()
 644; 			       ((_ (mylet-symb mylet*-symb myletrec-symb
 645; 					       mylambda-symb mymm-symb 
 646; 					       myfoo-symb) vars body)
 647; 				(lambda-native vars
 648; 				  (make-mm mymm-symb myfoo-symb
 649; 				    (do-defile	; proliferate in the body
 650; 				     (mylet-symb mylet*-symb myletrec-symb
 651; 						 mylambda-symb
 652; 						 mymm-symb myfoo-symb)
 653; 				     body)))))))
 654; 			 (extract* (let-symb let*-symb letrec-symb lambda-symb
 655; 					     mm-symb foo-symb)
 656; 				   (_vars _body)
 657; 				   (doit () _vars _body))))))
 658
 659; 		   (lambda-native	; capture the native lambda
 660; 		    (syntax-rules ()
 661; 		      ((_ . args) (lambda . args))))
 662; 		   )
 663
 664; 		body-to-defile)))))
 665
 666;        (extract* (let let* letrec lambda mm foo) dbody
 667; 		 (do-defile () dbody))
 668;        ))))
 669
 670; ; (define-syntax let
 671; ;   (syntax-rules ()
 672; ;     ((_ . args) (dlet let . args))))
 673
 674
 675
 676; ; (define-syntax alet
 677; ;   (syntax-rules ()
 678; ;     ((_ . args) 
 679; ;      (let-syntax
 680; ; 	 ((doit
 681; ; 	   (syntax-rules ()
 682; ; 	      ((_ (let-symb) body) (defile1 let-symb (blet . body))))))
 683; ;        (extract* (blet) args (doit () args))))))
 684
 685
 686; (display "corrupted-let")
 687; (newline)
 688; (display
 689;  (let ((foo 2)) (list (mm) foo))
 690;  )
 691
 692; (newline)
 693; (display
 694;    (let ((foo 2)) (let ((foo 3)) (let ((foo 4)) (list (mm) foo))))
 695;    )
 696; (newline)
 697; ; ==> (4 4)
 698
 699; (display
 700;    (let ((foo 2))
 701;      (let ((foo 3) (bar (list (mm) foo)))
 702;        (list foo (mm) bar)))
 703;    )
 704; (newline)
 705; ; ==> (3 3 (2 2)) 
 706
 707; (display
 708;    (let ((foo 2))
 709;      (list
 710;       ((letrec ((bar (lambda () (list foo (mm))))
 711; 		(foo 3))
 712; 	bar))
 713;       foo (mm))))
 714; (newline)
 715; ;==> ((3 3) 2 2) 
 716
 717; (display
 718;    (let ((foo 2))
 719;      (let foo ((flag #t) (lst (list foo (mm))))
 720;        (if flag ((mm) #f (list lst lst)) lst))))
 721; (newline)
 722; ; ==> ((2 2) (2 2)) 
 723
 724; (display
 725;  (let ()
 726;   (let* ((foo 2) 
 727; 	 (i 3)
 728; 	 (foo 4) 
 729; 	 (ft (lambda () (mm))) ; will capture binding of foo to 4
 730; 	 (foo 5)
 731; 	 (ft1 (lambda (foo) (mm))) ; will  capture the arg of ft1
 732; 	 (foo 6))
 733;     (list foo (mm) (ft) (ft1 7) '(mm))))
 734;   )
 735; (newline)
 736; ; ==> (6 6 4 7 (mm))
 737
 738
 739(define-syntax defile-what
 740  (syntax-rules ()
 741    ((_ dirty-macro-name dirty-macro-name-gen captured-symbol dbody)
 742     (letrec-syntax
 743	 ((do-defile
 744	   (syntax-rules ()	; all the shadowed symbols
 745	     ((_ (let-symb let*-symb letrec-symb lambda-symb mm-symb foo-symb)
 746		 body-to-defile)
 747	      (letrec-syntax
 748		  ((let-symb		; R5RS definition of let
 749		    (syntax-rules ()
 750		      ((_ . args)
 751		       (glet (let-symb let*-symb letrec-symb lambda-symb)
 752			     . args))))
 753
 754		   (let*-symb		; Redefinition of let*
 755		    (syntax-rules ()
 756		      ((_ . args) 
 757		       (glet* (let-symb let*-symb letrec-symb lambda-symb) 
 758			      . args))))
 759
 760		   (letrec-symb		; Redefinition of letrec
 761		    (syntax-rules ()
 762		      ((_ . args) 
 763		       (gletrec (let-symb let*-symb letrec-symb lambda-symb) 
 764			      . args))))
 765		       (lambda-symb         ; re-defined, infected lambda
 766		    (syntax-rules ()
 767		      ((_ _vars _body)
 768		       (letrec-syntax 
 769			   ((doit
 770			     (syntax-rules ()
 771			       ((_ (mylet-symb mylet*-symb myletrec-symb
 772					       mylambda-symb mymm-symb 
 773					       myfoo-symb) vars body)
 774				(lambda-native vars
 775				  (dirty-macro-name-gen mymm-symb myfoo-symb
 776				    (do-defile	; proliferate in the body
 777				     (mylet-symb mylet*-symb myletrec-symb
 778						 mylambda-symb
 779						 mymm-symb myfoo-symb)
 780				     body))))))
 781			    (proliferate
 782			     (syntax-rules ()
 783			       ((_ dummy __vars __body)
 784				(extract* (let-symb let*-symb 
 785						    letrec-symb lambda-symb
 786						    mm-symb foo-symb)
 787					  (__vars __body)
 788					  (doit () __vars __body)))))
 789			    (stop-infection
 790			     (syntax-rules ()
 791			       ((_ dummy __vars __body)
 792				(lambda-native __vars __body))))
 793			    )
 794			 (extract? mm-symb _vars
 795			    ; true-continuation
 796			    (stop-infection () _vars _body)
 797			    ; false-cont
 798			    (proliferate () _vars _body))
 799			 ))))
 800
 801; 		   (lambda-symb         ; re-defined, infected lambda
 802; 		    (syntax-rules ()
 803; 		      ((_ _vars _body)
 804; 		       (letrec-syntax 
 805; 			   ((doit
 806; 			     (syntax-rules ()
 807; 			       ((_ (mylet-symb mylet*-symb myletrec-symb
 808; 					       mylambda-symb mymm-symb 
 809; 					       myfoo-symb) vars body)
 810; 				(lambda-native vars
 811; 				  (dirty-macro-name-gen mymm-symb myfoo-symb
 812; 				    (do-defile	; proliferate in the body
 813; 				     (mylet-symb mylet*-symb myletrec-symb
 814; 						 mylambda-symb
 815; 						 mymm-symb myfoo-symb)
 816; 				     body)))))))
 817; 			 (extract* (let-symb let*-symb letrec-symb lambda-symb
 818; 					     mm-symb foo-symb)
 819; 				   (_vars _body)
 820; 				   (doit () _vars _body))))))
 821
 822		   (lambda-native	; capture the native lambda
 823		    (syntax-rules ()
 824		      ((_ . args) (lambda . args))))
 825		   )
 826
 827		body-to-defile)))))
 828
 829       (extract* (let let* letrec lambda dirty-macro-name captured-symbol) dbody
 830		 (do-defile () dbody))
 831       ))))
 832
 833
 834(define-syntax let-defiled-syntax
 835  (syntax-rules ()
 836    ((_ var-to-capture ((dm-name dm-body)) body)
 837     (let-syntax
 838	 ((dm-generator
 839	   (syntax-rules ()
 840	     ((_ dmg-name var-to-capture dmg-outer-body)
 841	      (let-syntax 
 842		  ((dmg-name dm-body))
 843		dmg-outer-body)))))
 844       (defile-what
 845	 dm-name dm-generator var-to-capture body)
 846       ))))
 847
 848(display "defile-what") (newline)
 849(display
 850 (let-defiled-syntax
 851  bar ((mbar (syntax-rules () ((_ val) (+ bar val)))))
 852  (let ((bar 1)) (let ((bar 2)) (mbar 2))))
 853)
 854(newline)
 855
 856(display "defile-what") (newline)
 857(display
 858 (let-defiled-syntax
 859  quux ((mquux (syntax-rules () ((_ val) (+ quux quux val)))))
 860  (let* ((bar 1) (quux 0) (quux 2) 
 861	 (lquux (lambda (x) (mquux x)))
 862	 (quux 3)
 863	 (lcquux (lambda (quux) (mquux quux)))) ; will tripple its arg
 864    (list (+ quux quux) (mquux 0) (lquux 2) (lcquux 5)))))
 865(newline)
 866; ==> (6 6 6 15)
 867
 868; testing shadowing
 869(display "test shadowing") (newline)
 870(display
 871 (let-defiled-syntax
 872  quux ((mquux (syntax-rules () ((_ val) (+ quux quux val)))))
 873    (let* ((bar 1) (quux 0) (quux 2) 
 874	   (lquux (lambda (x) (mquux x)))
 875	   (mquux (lambda (val) 0))
 876	   (lcquux (lambda (quux) (mquux quux)))) ; will tripple its arg
 877      (list (+ quux quux) (mquux 0) (lquux 2) (lcquux 5)))))
 878(newline)
 879; ==> (4 0 6 0)
 880(display
 881 (let-syntax
 882  ((mquux (syntax-rules () ((_ val) (+ quux quux val)))))
 883  (let ((mquux (lambda (val) 0)))
 884    (let* ((bar 1) (quux 0) (quux 2) 
 885	   (lquux (lambda (x) (mquux x)))
 886	   (lcquux (lambda (quux) (mquux quux)))) ; will tripple its arg
 887      (list (+ quux quux) (mquux 0) (lquux 2) (lcquux 5))))))
 888(newline)
 889; ==> (4 0 0 0)
 890
 891(display
 892 (let-defiled-syntax
 893  quux ((mquux (syntax-rules () ((_ val) (+ quux quux val)))))
 894  (let-syntax ((mquux (syntax-rules () ((_ val) 0))))
 895    (let* ((bar 1) (quux 0) (quux 2) 
 896	   (lquux (lambda (x) (mquux x)))
 897	   (lcquux (lambda (quux) (mquux quux)))) ; will tripple its arg
 898      (list (+ quux quux) (mquux 0) (lquux 2) (lcquux 5))))))
 899; ==> (4 0 0 0)
 900
 901(display
 902  (defile
 903    (let-syntax
 904      ((test2
 905	 (syntax-rules (mm)
 906	   ((_ mm) 'okay)
 907	   ((_ x) 'wrong))))
 908      (list
 909	(test2 mm)
 910	(let ((foo 3)) (test2 mm))))))
 911(newline)
 912
 913; extracting on a different sort of criteria
 914
 915;   extract2 MARKER BODY CONT
 916; Search the body for the occurrence of the form (SYMB MARKER . REST)
 917; where SYMB is a symbol. MARKER is a string, boolean, or number.
 918; For simplicity, we don't check that SYMB
 919; is a symbol, but we could: see a macro m-symbol?.
 920; CONT is a list (K-HEAD () . K-REST)
 921; If we found such a form, expand into
 922; (K-HEAD SYMB  . K-REST)
 923; If we didn't find what we searched for, expand into
 924; (K-HEAD nai . K-REST)
 925
 926
 927(define-syntax extract2
 928  (syntax-rules ()
 929    ((_ _marker _body _cont)
 930      (letrec-syntax
 931	((lp
 932           (syntax-rules ()
 933	      ((_ (symb _marker . rest) stack (cont-head () . cont-args))
 934	       (cont-head symb . cont-args)) ; found
 935	      ((_ (x . y) stack cont)   ; if body is a composite form,
 936	       (lp x (y . stack) cont)) ; look inside
 937	      ((_ d () (cont-head () . cont-args))
 938	       (cont-head nai . cont-args)) ; symb does not occur
 939	      ((_ d (x . y) cont)
 940	       (lp x y cont)))))
 941	(lp _body () _cont)))))
 942
 943
 944(define-syntax loop
 945  (syntax-rules ()
 946    ((_ . exps)
 947      (let-syntax
 948	((cont
 949	   (syntax-rules ()
 950	     ((_ ident exps_)
 951	       (call-with-current-continuation
 952		 (lambda (k)
 953		   (let ((ident (lambda (dummy value) (k value))))
 954		     (let f ()
 955		       (begin 'prevent-empty-begin . exps_)
 956		       (f)))))))))
 957	(extract2 "this one" exps (cont () exps))))))
 958
 959
 960(display "loop") (newline)
 961(display (loop (break "this one" 'foo)))
 962(newline)
 963; ==> foo
 964
 965(display "nested loop") (newline)
 966(display
 967  (loop
 968    (loop
 969      (break "this one" 'foo))
 970    (break "this one" 'bar)))
 971; ==> bar
 972(newline)
 973
 974(display "loop: shadowing") (newline)
 975(display
 976  (let ((break (lambda (dummy x) x)))
 977    (loop (break "this one" 'foo))
 978    (break "this one" 'bar)))
 979(newline)
 980
 981; Petrofsky:
 982; There are problems with writing extensions to loop.  Suppose we want
 983; to write loop-while, which adds a test that is checked once each time
 984; around the loop, and still binds an exit procedure.  We might think it
 985; could be written like this:
 986
 987(define-syntax loop-while
 988  (syntax-rules ()
 989    ((_ test exp ...)
 990      (loop
 991	(if (not test) (break "this one" #f))
 992	exp ...))))
 993
 994(display "loop-while") (newline)
 995(display
 996  (let ((n 0))
 997    (loop-while (< n 5)
 998      (set! n (+ n 1)))
 999    n))
 1000; ==> 5
1001(newline)
1002
1003(display
1004  (loop
1005    (let ((n 0))
1006      (loop-while (< n 5)
1007	(set! n (+ n 1))
1008	(if (= n 2)
1009	  (break "this one" 'foo)))
1010      (break "this one" 'bar))))
1011(newline)
1012
1013
1014; (define-syntax make-lambda 
1015;   (syntax-rules ()
1016;     ((_ . args) (lambda . args))))
1017
1018; (define-syntax make-lambda 
1019;   (syntax-rules ()
1020;     ((_ bindings body ...)
1021;       (let () (define (proc . bindings) body ...)
1022; 	proc))))
1023
1024(define-syntax make-lambda 
1025  (syntax-rules ()
1026    ((_ bindings body ...)
1027      (let-syntax () (define (proc . bindings) body ...)
1028	proc))))
1029
1030(define-syntax lambda
1031  (syntax-rules ()
1032    ((_ bindings body1 body2 ...)
1033     (make-lambda bindings
1034       (display "OK") (newline)
1035       (begin body1 body2 ...)))))
1036
1037(display "lambda-test") (newline)
1038(let ((p (lambda (x y z) (list x y z))))
1039  (display (p 1 2 3)))
1040(newline)
1041
1042(define-syntax mm
1043  (syntax-rules ()
1044    ((_ dummy) foo)
1045    ((_ dummy k) (k foo))))
1046
1047(define-syntax make-mm
1048  (syntax-rules ()
1049    ((_ mm foo bodies)
1050      (let-syntax
1051	((mm
1052	   (syntax-rules ()
1053	     ((_ dummy) foo)
1054	     ((_ dummy (kh () . kargs)) (kh foo . kargs)))))
1055	. bodies))))
1056
1057(define-syntax recolor
1058  (syntax-rules ()
1059    ((_ from to bodies . rest)
1060      (let-syntax 
1061	((ren
1062	   (syntax-rules ()
1063	     ((_ from) bodies))))
1064	(ren to)))))
1065
1066(define-syntax nai
1067  (syntax-rules ()
1068    ((_ dummy (kh () . kargs)) (kh nai . kargs))))
1069
1070(define-syntax lambda
1071  (syntax-rules ()
1072    ((_ bindings . bodies)
1073      (letrec-syntax
1074	((test
1075	   (syntax-rules ()
1076	     ((_ symb exp _kt _kf)
1077	       (letrec-syntax
1078		 ((loop
1079		    (syntax-rules (symb)
1080		      ((_ d () kt kf) kf)
1081		      ((_ (s . r1) (symb . r2) (kh () . kargs) kf)
1082			(kh s . kargs))
1083		      ((_ d (x . rest) kt kf) (loop rest rest kt kf)))))
1084		 (loop exp exp _kt _kf)))))
1085	 (doit
1086	   (syntax-rules ()
1087	     ((_ foo orig-foo bindings_ bodies_)
1088	       (extract2 "mm" bodies_
1089		 (cont () foo orig-foo bindings_ bodies_)))))
1090	 (cont
1091	   (syntax-rules ()
1092	     ((_ mm bindings_ bodies_)
1093	      (mm dummy (cont2 () mm bindings_ bodies_)))))
1094	  (cont2
1095	    (syntax-rules ()
1096	      ((_ xxx foo mm bindings_ bodies_)
1097	       (test foo bindings_
1098		 (cont3 () mm bindings_ bodies_)
1099		 (make-lambda bindings_ bodies_)))))
1100	  (cont3
1101	    (syntax-rules ()
1102	      ((_ foo mm bindings_ bodies_)
1103		(make-lambda bindings_
1104		  (make-mm mm foo
1105		    bodies_))))))
1106	(extract2 "mm" bodies
1107	  (cont () bindings bodies))))))
1108
1109
1110; (define-syntax let
1111;   (syntax-rules ()
1112;     ((_ ((v i)) . bodies)
1113;       ((lambda (v) . bodies) i))))
1114
1115(define-syntax let*
1116  (syntax-rules ()
1117    ((_ () . bodies) (begin . bodies))
1118    ((_ ((v i) . rest) . bodies)
1119      ((lambda (v) (let* rest . bodies)) i))))
1120;    ((_ . args) (glet* (let let* letrec lambda) . args))))
1121
1122(display (let* ((foo 2)) (list foo (mm "mm"))))
1123
1124(display
1125 (let* ((foo 2) 
1126	(i 3)
1127	(foo 4) 
1128	(ft (lambda () (mm "mm")))  ; will capture binding of foo to 4
1129	(foo 5)
1130	(ft1 (lambda (foo) (mm "mm")))	; will  capture the arg of ft1
1131	(foo 6))
1132   (list foo (mm "mm") (ft) (ft1 7) '(mm "mm"))))
1133(newline)
1134; ==> (6 6 4 7 (mm))
1135
1136