source: project/chicken/branches/hygienic/tests/dirty-macros.scm @ 11524

Last change on this file since 11524 was 11524, checked in by felix winkelmann, 12 years ago

re-loading imported module into interpreter incorrectly renamed export list (export-lists are now sytax-stripped); started with guerilla setup

File size: 29.7 KB
Line 
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
Note: See TracBrowser for help on using the repository browser.