Changeset 29985 in project


Ignore:
Timestamp:
11/02/13 15:24:37 (8 years ago)
Author:
juergen
Message:

version 0.4 with define-anaphor define-properties tree-recurser atree-recurser list-recurser alist-recurser

Location:
release/4/anaphora
Files:
8 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/anaphora/tags/0.4/anaphora.meta

    r24983 r29985  
    44 (category lang-exts)
    55 (license "BSD")
    6  (doc-from-wiki #t)
     6 (test-depends simple-tests)
    77 (author "Juergen Lorenz")
    88 (files "anaphora.setup" "anaphora.release-info" "anaphora.meta" "anaphora.scm" "tests/run.scm"))
  • release/4/anaphora/tags/0.4/anaphora.scm

    r25285 r29985  
    3737
    3838;Inspired by Paul Graham's classic "On Lisp" this module introduces
    39 ;anaphoric macros, which are unhygienic by design. Hence they can not
     39;anaphoric macros, which are unhygienic by design. Hence they can not be
    4040;implemented with syntax-rules! In fact, they introduce new identifiers
    4141;behind the scene, mostly named it, which can be referenced in the body
    4242;without being declared. Please note, that this identifier is not
    4343;renamed!
    44 ;
    45 ;We implement all anaphoric macros with ir-macro-transformer.
    46 
    47 (module anaphora *
    48 
    49 (import scheme (only chicken case-lambda print))
    50 
    51 ;;; (aif test? consequent [alternative])
     44
     45(module anaphora
     46
     47(export anaphora aif awhen acond awhile aand alambda define-anaphor
     48        define-properties alist-recurser atree-recurser
     49        tree-recurser list-recurser)
     50(import scheme (only chicken case-lambda gensym print)) ;;print
     51
     52;;; (aif test consequent [alternative])
    5253;;; ------------------------------------
    5354;;; anaphoric if, where consequent and alternative can refer to result
    54 ;;; of test? named it
     55;;; of test named it
    5556(define-syntax aif
    5657  (ir-macro-transformer
     
    5859      (let ((it (inject 'it)))
    5960        (let (
    60           (test? (cadr form))
     61          (test (cadr form))
    6162          (consequent (caddr form))
    6263          (alternative (cdddr form))
    6364          )
    6465          (if (null? alternative)
    65             `(let ((,it ,test?))
     66            `(let ((,it ,test))
    6667               (if ,it ,consequent))
    67             `(let ((,it ,test?))
     68            `(let ((,it ,test))
    6869               (if ,it ,consequent ,(car alternative)))))))))
    6970
    70 ;;; (awhen test? xpr . xprs)
     71;;; (awhen test xpr . xprs)
    7172;;; ------------------------
    72 ;;; anaphoric when, where xpr ... can refer to result of test?
     73;;; anaphoric when, where xpr ... can refer to result of test
    7374;;; named it
    7475(define-syntax awhen
     
    7778      (let ((it (inject 'it)))
    7879        (let (
    79           (test? (cadr form))
     80          (test (cadr form))
    8081          (xpr (caddr form))
    8182          (xprs (cdddr form))
    8283          )
    83           `(let ((,it ,test?))
     84          `(let ((,it ,test))
    8485             (if ,it (begin ,xpr ,@xprs))))))))
    8586
    8687;;; (acond . clauses)
    8788;;; -----------------
    88 ;;; anaphoric cond, where each clause is a list (test? xpr ...) in which
    89 ;;; each xpr can refer to result of test? named it.
     89;;; anaphoric cond, where each clause is a list (test xpr ...) in which
     90;;; each xpr can refer to result of test named it.
    9091;;; The last clause can start with else which evaluates to #t.
    9192(define-syntax acond
     
    107108                     ,(loop (cdr clauses))))))))))))
    108109
    109 ;;; (awhile test? xpr . xprs)
     110;;; (awhile test xpr . xprs)
    110111;;; -------------------------
    111112;;; anaphoric while, where each xpr ... can refer to the result of
    112 ;;; the successive test?, named it
     113;;; the successive test, named it
    113114(define-syntax awhile
    114115  (ir-macro-transformer
     
    116117      (let ((it (inject 'it)))
    117118        (let (
    118           (test? (cadr form))
     119          (test (cadr form))
    119120          (xpr (caddr form))
    120121          (xprs (cdddr form))
    121122          )
    122           `(let loop ((,it ,test?))
     123          `(let loop ((,it ,test))
    123124             (when ,it
    124125               ,xpr ,@xprs
    125                (loop ,test?))))))))
     126               (loop ,test))))))))
    126127
    127128;;; (aand . args)
     
    155156             ,self))))))
    156157
     158#|[
     159Most of  the anaphoric macros above could be generated automatically by
     160means of the following macro, define-anaphor, which generates another
     161macro defining it. It accepts three arguments, the name of the new
     162macro to be defined, the name of the procedure or macro on which the
     163anaphoric macro is patterned and a rule transforming the latter into the
     164former, presently one of the procedures cascade-it and first-it.
     165cascade-it produces a cascade of variables named it, storing the
     166values of the previous arguments as in aand above, where first-it stores
     167only the first argument as variable it to be used in any of the
     168following arguments as in awhen above.  So we could have defined them as
     169
     170  (define-anaphor aand and cascade-it)
     171  (define-anaphor awhen when first-it)
     172
     173and used as follows
     174
     175  (aand '(1 2 3) (cdr it) (cdr it)) ; -> '(3)
     176  (awhen (! 5) it (* 2 it)) ; -> 240
     177
     178where ! is the factorial.
     179But note, that define-anaphor could be used for any function as well,
     180for example
     181
     182  (define-anaphor a* * cascade-it)
     183  (a* 10 (* 2 it) (+ 5 it)) ; -> 35
     184]|#
     185
     186;;; (define-anaphor name from rule)
     187;;; -------------------------------
     188;;; defines an anaphoric macro, name, patterned after the fuction or
     189;;; macro from and transformed according to rule, one of the symbols
     190;;; cascade or first.
     191;;; Note, that this macro is hygienic, but it creates an anaphoric one.
     192(define-syntax define-anaphor
     193  (syntax-rules ()
     194    ((_ name from rule)
     195     (define-syntax name
     196       (er-macro-transformer
     197         (lambda (form rename compare?)
     198           (let ((%let (rename 'let)) (%let* (rename 'let*)))
     199             (letrec (
     200               (cascade-it
     201                 (lambda (op args)
     202                   (let loop ((args args) (xpr `(,op)))
     203                     (if (null? args)
     204                       xpr
     205                       (let ((sym (gensym)))
     206                         `(,%let* ((,sym ,(car args)) (it ,sym))
     207                                  ,(loop (cdr args)
     208                                         (append xpr (list sym)))))))))
     209               (first-it
     210                 (lambda (op args)
     211                   `(,%let ((it ,(car args)))
     212                           (,op it ,@(cdr args)))))
     213               )
     214               (case rule
     215                 ((#:cascade)
     216                  (cascade-it 'from (cdr form)))
     217                 ((#:first)
     218                  (first-it 'from (cdr form)))
     219                 (else
     220                   (error 'define-anaphor
     221                       "rule must be one of #:cascade or #:first")))))))))))
     222;(define-syntax define-anaphor
     223;  (syntax-rules ()
     224;    ((_ name from rule)
     225;     (define-syntax name
     226;       (er-macro-transformer
     227;         (lambda (form rename compare?)
     228;           (rule 'from (cdr form) rename)))))))
     229;
     230;(define (first-it op args rename)
     231;  (let ((%let (rename 'let)))
     232;    `(,%let ((it ,(car args)))
     233;            (,op it ,@(cdr args)))))
     234;
     235;(define (cascade-it op args  rename)
     236;  (let ((%let* (rename 'let*)))
     237;    (let loop ((args args) (xpr `(,op)))
     238;      (if (null? args)
     239;        xpr
     240;        (let ((sym (gensym)))
     241;          `(,%let* ((,sym ,(car args)) (it ,sym))
     242;                   ,(loop (cdr args) (append xpr (list sym)))))))))
     243
     244#|[
     245The following macro defines new macros masking property-accessors and
     246-mutators get and put!  For each supplied identifier, prop, another
     247identifier, prop!, is constructed behind the scene. The former will be
     248the accessor, the latter the mutator. So
     249  (prop sym)
     250is expands into
     251  (get sym 'prop)
     252and
     253  (prop! sym val)
     254into
     255  (put! sym 'prop val)
     256Note how the new names with the ! suffix are generated at compile time,
     257i.e. within an unquote. Note also the use of the injection argument, i, for
     258the property-name, prop, and the suffixed name, prop!, within that unquote.
     259]|#
     260
     261;;; (define-properties . names)
     262;;; ---------------------------
     263;;; defines, for each name, property-accessors and -mutators
     264;;; name and name!
     265(define-syntax define-properties
     266  (ir-macro-transformer
     267    (lambda (f i c?)
     268      `(begin
     269         ,@(map (lambda (prop)
     270                  `(begin
     271                     (define-syntax ,prop
     272                       (ir-macro-transformer
     273                         (lambda (form inject compare?)
     274                           `(get ,(cadr form) ',',prop))))
     275                     (define-syntax ,(i (string->symbol
     276                                          (string-append
     277                                            (symbol->string (i prop))
     278                                            "!")))
     279                       (ir-macro-transformer
     280                         (lambda (form inject compare?)
     281                           `(put! ,(cadr form)
     282                                  ',',prop
     283                                  ,(caddr form)))))))
     284                (cdr f))))))
     285
     286#|[
     287The following two macros and two procedures represent recursion an lists
     288and trees respectively. They are, again, inspired by Graham. The
     289procedures are defined with alambda, the anaphoric version of lambda
     290with injected symbol self.  These procedures, list-recurser and
     291tree-recurser,  accept a recurser and a base as arguments, the recurser
     292being itself procedures accepting the actual list or tree as argument,
     293as well as one or two thunks representing recursion along the cdr or the
     294car and the cdr respectively.
     295The macros, alist-recurser and atree-recurser, are anaphoric versions of
     296the procedures list-recurser and tree-recurser. They both inject the
     297symbol it behind the scene, representing the actual list or tree
     298respectively, as well as symbols go-on or go-left and go-right
     299respectively representing the recurser arguments of the functions.
     300
     301The relations between the procedures and the anaphoric macros are shown
     302in the following exaples:
     303  (define lcopy
     304    (list-recurser (lambda (lst th) (cons (car lst) (th))) '()))
     305  (define alcopy
     306    (alist-recurser (cons (car it) (go-on)) '()))
     307  (define tcopy
     308    (tree-recurser (lambda (tree left right)
     309                     (cons (left) (or (right) '())))
     310                   identity))
     311  (define atcopy
     312    (atree-recurser (cons (go-left) (or (go-right) '())) it))
     313]|#
     314
     315;;; (alist-recurser recurser base)
     316;;; ------------------------------
     317;;; wrapping list-recurser into an anaphoric macro with injected symbols it and go-on
     318;;; where it is the list itself and go-on the recurser-thunk
     319(define-syntax alist-recurser
     320  (ir-macro-transformer
     321    (lambda (form inject compare?)
     322      (let ((it (inject 'it))
     323            (go-on (inject 'go-on)))
     324        `(list-recurser (lambda (,it thunk)
     325                          (letrec ((,go-on thunk))
     326                            ,(cadr form)))
     327                        ,@(cddr form))))))
     328
     329;;; (atree-recurser recurser base)
     330;;; ------------------------------
     331;;; wrapping tree-recurser into an anaphoric macro with injected symbols
     332;;; it, go-left and go-right representing the actual tree and recursers
     333;;; along the car and the cdr respectively.
     334(define-syntax atree-recurser
     335  (ir-macro-transformer
     336    (lambda (form inject compare?)
     337      (let ((recurser (cadr form))
     338            (base (caddr form))
     339            (it (inject 'it))
     340            (go-left (inject 'go-left))
     341            (go-right (inject 'go-right)))
     342        `(tree-recurser
     343           (lambda (,it left right)
     344             (letrec ((,go-left left)
     345                      (,go-right right))
     346               ,recurser))
     347           (lambda (,it) ,base))))))
     348
     349;;; (list-recurser recurser base)
     350;;; -----------------------------
     351;;; recurser is a procedure of a list and a thunk processing the cdr
     352(define (list-recurser recurser base)
     353  (alambda (lst)
     354    (if (null? lst)
     355      (if (procedure? base)
     356        (base)
     357        base)
     358      (recurser lst
     359                (lambda ()
     360                  (self (cdr lst)))))))
     361
     362;;; (tree-recurser recurser base)
     363;;; -----------------------------
     364;;; recurser is a procedure of a tree and two thunks processing the car
     365;;; and the cdr
     366(define (tree-recurser recurser base)
     367  (alambda (tree)
     368    (cond
     369      ((pair? tree)
     370       (recurser tree
     371                 (lambda ()
     372                   (self (car tree)))
     373                 (lambda ()
     374                   (if (null? (cdr tree))
     375                     #f
     376                     (self (cdr tree))))))
     377      (else ; atom
     378        (if (procedure? base)
     379          (base tree)
     380          base)))))
     381
    157382;;; documentation dispatcher
    158383
     
    161386    (alist '(
    162387      (aif
    163         (aif test? consequent [alternative])
    164         "anaphoric if, consequent and alternative can refer to result it
    165 of test?")
     388        (macro it ()
     389          (aif consequent)
     390          (aif consequent alternative)))
    166391      (awhen
    167          (awhen test? xpr . xprs)
    168          "anaphoric when, where xpr ... can refer to result of test?
    169 named it")
     392        (macro it ()
     393          (awhen xpr . xprs)))
    170394      (acond
    171         (acond . clauses)
    172         "anaphoric cond, where each clause is a list (test? xpr ...) in which
    173 each xpr can refer to result of test? named it.
    174 The last clause can start with else which evaluates to #t.")
     395        (macro it ()
     396          (acond clauses)))
    175397      (awhile
    176         (awhile test? xpr . xprs)
    177         "anaphoric while, where each xpr ... can refer to the result of
    178 the successive test?, named it")
     398        (macro it ()
     399          (awhile xpr . xprs)))
    179400      (aand
    180         (aand . args)
    181         "anaporic and, each arg can refer to the previous arg with it")
     401        (macro it ()
     402          (aand args)))
    182403      (alambda
    183         (alambda args . body)
    184         "anaphoric lambda, where body can refer to self")
    185       )))
     404        (macro self ()
     405          (alambda . body)))
     406      (define-anaphor
     407        (macro ()
     408          (define-anaphor name from rule)))
     409      (define-properties
     410        (macro name! ... ()
     411          (define-properties name ...)))
     412      (list-recurser
     413        (procedure
     414          (list-recurser (lambda (lst thunk) ...)  base)))
     415      (alist-recurser
     416        (macro it go-on ()
     417          (alist-recurser recurser-xpr base-xpr)))
     418      (tree-recurser
     419        (procedure
     420          (tree-recurser (lambda (tree thunk0 thunk1) ...)  base)))
     421      (atree-recurser
     422        (macro it go-left go-right ()
     423          (atree-recurser recurser-xpr base-xpr)))))
     424    )
    186425    (case-lambda
    187426      (() (map car alist))
     
    189428       (let ((pair (assq sym alist)))
    190429         (if pair
    191            (cdr pair)
    192            (print "Choose one of " (map car alist))))))))
     430           (cadr pair)
     431           (begin
     432             (display "Choose one of ")
     433             (display (map car alist)))))))))
    193434
    194435) ; module anaphora
  • release/4/anaphora/tags/0.4/anaphora.setup

    r25285 r29985  
    77 'anaphora
    88 '("anaphora.so" "anaphora.import.so")
    9  '((version "0.3.1")))
     9 '((version "0.4")))
    1010
    1111
  • release/4/anaphora/tags/0.4/tests/run.scm

    r24376 r29985  
    1 ;;;; File: anaphora-run.scm
    2 ;;;; Author: Juergen Lorenz
    3 ;;;; ju (at) jugilo (dot) de
    4 ;;;; Date: Jun 20, 2011
     1(require-library anaphora simple-tests)
     2(import anaphora simple-tests)
    53
    6 
    7 (require 'anaphora)
    8 (import anaphora)
    9 
    10 (define run
    11   (lambda ()
    12     (if
    13       (and
    14         (equal?
    15           (aif (memv 3 '(1 2 3 4 5))
    16             it)
    17           '(3 4 5))
    18         (equal?
    19           (acond
    20             ((memv 6 '(1 2 3 4 5)) it)
    21             ((memv 3 '(1 2 3 4 5)) it)
    22             (else it))
    23           '(3 4 5))
    24         (eq?
    25           (acond
    26             ((memv 6 '(1 2 3 4 5)) it)
    27             (else it))
    28           #t)
    29         (eq?
    30           (acond
    31             ((memv 6 '(1 2 3 4 5)) it)
    32             (else #f))
    33           #f)
    34         (equal?
    35           (let ((lst '(1 2 3 4 5 #f)) (res '()))
    36             (awhile (car lst)
    37               (set! res (cons (car lst) res))
    38               (set! lst (cdr lst)))
    39             res)
    40         '(5 4 3 2 1))
    41         (equal?
    42           (awhen (memv 3 '(1 2 3 4 5)) it)
    43           '(3 4 5))
    44         (=
    45           (aand '(1 2 3 4 5) (cdr it) (car it))
    46           2)
    47         (equal?
    48           (map (alambda (n)
    49                  (if (zero? n)
    50                    1
    51                    (* n (self (- n 1)))))
    52                '(1 2 3 4 5))
    53           '(1 2 6 24 120)))
    54         (print "All tests passed")
    55         (print "##### Some tests failed #####"))))
    56 
    57 (run)
    58 
     4(compound-test ('ANAPHORA)
     5  (simple-test ('BASICS)
     6    (equal?
     7      (aif (memv 3 '(1 2 3 4 5))
     8        it)
     9      '(3 4 5))
     10    (equal?
     11      (acond
     12        ((memv 6 '(1 2 3 4 5)) it)
     13        ((memv 3 '(1 2 3 4 5)) it)
     14        (else it))
     15      '(3 4 5))
     16    (eq?
     17      (acond
     18        ((memv 6 '(1 2 3 4 5)) it)
     19        (else it))
     20      #t)
     21    (eq?
     22      (acond
     23        ((memv 6 '(1 2 3 4 5)) it)
     24        (else #f))
     25      #f)
     26    (equal?
     27      (let ((lst '(1 2 3 4 5 #f)) (res '()))
     28        (awhile (car lst)
     29          (set! res (cons (car lst) res))
     30          (set! lst (cdr lst)))
     31        res)
     32    '(5 4 3 2 1))
     33    (equal?
     34      (awhen (memv 3 '(1 2 3 4 5)) it)
     35      '(3 4 5))
     36    (=
     37      (aand '(1 2 3 4 5) (cdr it) (car it))
     38      2)
     39    (equal?
     40      (map (alambda (n)
     41             (if (zero? n)
     42               1
     43               (* n (self (- n 1)))))
     44           '(1 2 3 4 5))
     45      '(1 2 6 24 120)))
     46  (simple-test ('PROPERTIES)
     47    (define-properties color weight)
     48    (color! 'foo 'red)
     49    (eq? (color 'foo) 'red)
     50    (weight! 'foo 5)
     51    (= (weight 'foo) 5)
     52    (color! 'foo 'blue)
     53    (eq? (color 'foo) 'blue)
     54    (weight! 'foo 50)
     55    (= (weight 'foo) 50))
     56  (simple-test ('LIST-RECURSERS)
     57    (define llength
     58      (list-recurser (lambda (lst th) (add1 (th))) 0))
     59    (define allength
     60      (alist-recurser (add1 (go-on)) 0))
     61    (= (llength '(1 2 3)) 3)
     62    (= (allength '(1 2 3)) 3)
     63    (define (lsome? ok?)
     64      (list-recurser (lambda (lst th) (or (ok? (car lst)) (th))) #f))
     65    (define (alsome? ok?)
     66      (alist-recurser (or (ok? (car it)) (go-on)) #f))
     67    ((lsome? odd?) '(2 3 4))
     68    ((alsome? odd?) '(2 3 4))
     69    (define (alevery? ok?)
     70      (alist-recurser (and (ok? (car it)) (go-on)) #t))
     71    (not ((alevery? odd?) '(1 2 3)))
     72    (define (lfind ok?)
     73      (list-recurser (lambda (lst th) (if (ok? (car lst)) lst (th))) '()))
     74    (define (alfind ok?)
     75      (alist-recurser (if (ok? (car it)) it (go-on)) '()))
     76    (equal? ((lfind odd?) '(2 3 4)) '(3 4))
     77    (equal? ((alfind odd?) '(2 3 4)) '(3 4))
     78    (define lcopy
     79      (list-recurser (lambda (lst th) (cons (car lst) (th))) '()))
     80    (define alcopy
     81      (alist-recurser (cons (car it) (go-on)) '()))
     82    (equal? (lcopy '(1 2 3)) '(1 2 3))
     83    (equal? (alcopy '(1 2 3)) '(1 2 3))
     84    (define lremove-dups
     85      (list-recurser (lambda (lst th) (adjoin (car lst) (th))) '()))
     86    (define alremove-dups
     87      (alist-recurser (adjoin (car it) (go-on)) '()))
     88    (define (adjoin obj lst) (if (member obj lst) lst (cons obj lst)))
     89    (equal? (sort (lremove-dups '(1 2 1 3 2 4 3)) <) '(1 2 3 4))
     90    (equal? (sort (alremove-dups '(1 2 1 3 2 4 3)) <) '(1 2 3 4)))
     91  (simple-test ('TREE-RECURSERS)
     92    (define tflatten
     93      (tree-recurser (lambda (tree left right)
     94                       (append (left)
     95                               (or (right) '())))
     96                     (lambda (tree)
     97                       (if (list? tree) tree (list tree)))))
     98    (define atflatten
     99      (atree-recurser (append (go-left) (or (go-right) '()))
     100                      (if (list? it) it (list it))))
     101    (equal? (tflatten '(1 (2 3 (4)) 5)) '(1 2 3 4 5))
     102    (equal? (atflatten '(1 (2 3 (4)) 5)) '(1 2 3 4 5))
     103    (define tcopy
     104      (tree-recurser (lambda (tree left right)
     105                       (cons (left) (or (right) '())))
     106                     identity))
     107    (define atcopy
     108      (atree-recurser (cons (go-left) (or (go-right) '())) it))
     109    (equal? (tcopy '(1 (2 3 (4)) 5)) '(1 (2 3 (4)) 5))
     110    (equal? (atcopy '(1 (2 3 (4)) 5)) '(1 (2 3 (4)) 5))
     111    (define (tfind ok?)
     112      (tree-recurser (lambda (tree left right)
     113                       (or (left) (right)))
     114                     (lambda (tree)
     115                       (and (ok? tree) tree))))
     116    (define (atfind ok?)
     117      (atree-recurser (or (go-left) (go-right))
     118                      (and (ok? it) it)))
     119    (= ((tfind odd?) '(2 (4 5) 1)) 5)
     120    (= ((atfind odd?) '(2 (4 6) 1)) 1)
     121    (define tcount-leaves
     122      (tree-recurser (lambda (tree left right)
     123                       (+ (left) (or (right) 1)))
     124                     1))
     125    (define atcount-leaves
     126      (atree-recurser (+ (go-left) (or (go-right) 1)) 1))
     127    (= (tcount-leaves '((1 2 (3 4)) (5) 6)) 10)
     128    (= (atcount-leaves '((1 2 (3 4)) (5) 6)) 10))
     129  (simple-test ('DEFINE-ANAPHOR)
     130    (define-anaphor alist list #:cascade)
     131    (define-anaphor a+ + #:cascade)
     132    (define-anaphor a- - #:cascade)
     133    (equal? (alist 1 (+ it 2) (* it 3)) '(1 3 9))
     134    (= (a+ 1 (+ it 2) (* it 3)) 13)
     135    (= (a- 1 (+ it 2) (* it 3)) -11)
     136    (define-anaphor aand and #:cascade)
     137    (equal? (aand (list 1 2 3) (cdr it) (cdr it)) '(3))
     138    (define-anaphor awhen when #:first)
     139    (= (awhen (* 1 2 3 4 5) (* 2 it)) 240))
     140)
  • release/4/anaphora/trunk/anaphora.meta

    r24983 r29985  
    44 (category lang-exts)
    55 (license "BSD")
    6  (doc-from-wiki #t)
     6 (test-depends simple-tests)
    77 (author "Juergen Lorenz")
    88 (files "anaphora.setup" "anaphora.release-info" "anaphora.meta" "anaphora.scm" "tests/run.scm"))
  • release/4/anaphora/trunk/anaphora.scm

    r25285 r29985  
    3737
    3838;Inspired by Paul Graham's classic "On Lisp" this module introduces
    39 ;anaphoric macros, which are unhygienic by design. Hence they can not
     39;anaphoric macros, which are unhygienic by design. Hence they can not be
    4040;implemented with syntax-rules! In fact, they introduce new identifiers
    4141;behind the scene, mostly named it, which can be referenced in the body
    4242;without being declared. Please note, that this identifier is not
    4343;renamed!
    44 ;
    45 ;We implement all anaphoric macros with ir-macro-transformer.
    46 
    47 (module anaphora *
    48 
    49 (import scheme (only chicken case-lambda print))
    50 
    51 ;;; (aif test? consequent [alternative])
     44
     45(module anaphora
     46
     47(export anaphora aif awhen acond awhile aand alambda define-anaphor
     48        define-properties alist-recurser atree-recurser
     49        tree-recurser list-recurser)
     50(import scheme (only chicken case-lambda gensym print)) ;;print
     51
     52;;; (aif test consequent [alternative])
    5253;;; ------------------------------------
    5354;;; anaphoric if, where consequent and alternative can refer to result
    54 ;;; of test? named it
     55;;; of test named it
    5556(define-syntax aif
    5657  (ir-macro-transformer
     
    5859      (let ((it (inject 'it)))
    5960        (let (
    60           (test? (cadr form))
     61          (test (cadr form))
    6162          (consequent (caddr form))
    6263          (alternative (cdddr form))
    6364          )
    6465          (if (null? alternative)
    65             `(let ((,it ,test?))
     66            `(let ((,it ,test))
    6667               (if ,it ,consequent))
    67             `(let ((,it ,test?))
     68            `(let ((,it ,test))
    6869               (if ,it ,consequent ,(car alternative)))))))))
    6970
    70 ;;; (awhen test? xpr . xprs)
     71;;; (awhen test xpr . xprs)
    7172;;; ------------------------
    72 ;;; anaphoric when, where xpr ... can refer to result of test?
     73;;; anaphoric when, where xpr ... can refer to result of test
    7374;;; named it
    7475(define-syntax awhen
     
    7778      (let ((it (inject 'it)))
    7879        (let (
    79           (test? (cadr form))
     80          (test (cadr form))
    8081          (xpr (caddr form))
    8182          (xprs (cdddr form))
    8283          )
    83           `(let ((,it ,test?))
     84          `(let ((,it ,test))
    8485             (if ,it (begin ,xpr ,@xprs))))))))
    8586
    8687;;; (acond . clauses)
    8788;;; -----------------
    88 ;;; anaphoric cond, where each clause is a list (test? xpr ...) in which
    89 ;;; each xpr can refer to result of test? named it.
     89;;; anaphoric cond, where each clause is a list (test xpr ...) in which
     90;;; each xpr can refer to result of test named it.
    9091;;; The last clause can start with else which evaluates to #t.
    9192(define-syntax acond
     
    107108                     ,(loop (cdr clauses))))))))))))
    108109
    109 ;;; (awhile test? xpr . xprs)
     110;;; (awhile test xpr . xprs)
    110111;;; -------------------------
    111112;;; anaphoric while, where each xpr ... can refer to the result of
    112 ;;; the successive test?, named it
     113;;; the successive test, named it
    113114(define-syntax awhile
    114115  (ir-macro-transformer
     
    116117      (let ((it (inject 'it)))
    117118        (let (
    118           (test? (cadr form))
     119          (test (cadr form))
    119120          (xpr (caddr form))
    120121          (xprs (cdddr form))
    121122          )
    122           `(let loop ((,it ,test?))
     123          `(let loop ((,it ,test))
    123124             (when ,it
    124125               ,xpr ,@xprs
    125                (loop ,test?))))))))
     126               (loop ,test))))))))
    126127
    127128;;; (aand . args)
     
    155156             ,self))))))
    156157
     158#|[
     159Most of  the anaphoric macros above could be generated automatically by
     160means of the following macro, define-anaphor, which generates another
     161macro defining it. It accepts three arguments, the name of the new
     162macro to be defined, the name of the procedure or macro on which the
     163anaphoric macro is patterned and a rule transforming the latter into the
     164former, presently one of the procedures cascade-it and first-it.
     165cascade-it produces a cascade of variables named it, storing the
     166values of the previous arguments as in aand above, where first-it stores
     167only the first argument as variable it to be used in any of the
     168following arguments as in awhen above.  So we could have defined them as
     169
     170  (define-anaphor aand and cascade-it)
     171  (define-anaphor awhen when first-it)
     172
     173and used as follows
     174
     175  (aand '(1 2 3) (cdr it) (cdr it)) ; -> '(3)
     176  (awhen (! 5) it (* 2 it)) ; -> 240
     177
     178where ! is the factorial.
     179But note, that define-anaphor could be used for any function as well,
     180for example
     181
     182  (define-anaphor a* * cascade-it)
     183  (a* 10 (* 2 it) (+ 5 it)) ; -> 35
     184]|#
     185
     186;;; (define-anaphor name from rule)
     187;;; -------------------------------
     188;;; defines an anaphoric macro, name, patterned after the fuction or
     189;;; macro from and transformed according to rule, one of the symbols
     190;;; cascade or first.
     191;;; Note, that this macro is hygienic, but it creates an anaphoric one.
     192(define-syntax define-anaphor
     193  (syntax-rules ()
     194    ((_ name from rule)
     195     (define-syntax name
     196       (er-macro-transformer
     197         (lambda (form rename compare?)
     198           (let ((%let (rename 'let)) (%let* (rename 'let*)))
     199             (letrec (
     200               (cascade-it
     201                 (lambda (op args)
     202                   (let loop ((args args) (xpr `(,op)))
     203                     (if (null? args)
     204                       xpr
     205                       (let ((sym (gensym)))
     206                         `(,%let* ((,sym ,(car args)) (it ,sym))
     207                                  ,(loop (cdr args)
     208                                         (append xpr (list sym)))))))))
     209               (first-it
     210                 (lambda (op args)
     211                   `(,%let ((it ,(car args)))
     212                           (,op it ,@(cdr args)))))
     213               )
     214               (case rule
     215                 ((#:cascade)
     216                  (cascade-it 'from (cdr form)))
     217                 ((#:first)
     218                  (first-it 'from (cdr form)))
     219                 (else
     220                   (error 'define-anaphor
     221                       "rule must be one of #:cascade or #:first")))))))))))
     222;(define-syntax define-anaphor
     223;  (syntax-rules ()
     224;    ((_ name from rule)
     225;     (define-syntax name
     226;       (er-macro-transformer
     227;         (lambda (form rename compare?)
     228;           (rule 'from (cdr form) rename)))))))
     229;
     230;(define (first-it op args rename)
     231;  (let ((%let (rename 'let)))
     232;    `(,%let ((it ,(car args)))
     233;            (,op it ,@(cdr args)))))
     234;
     235;(define (cascade-it op args  rename)
     236;  (let ((%let* (rename 'let*)))
     237;    (let loop ((args args) (xpr `(,op)))
     238;      (if (null? args)
     239;        xpr
     240;        (let ((sym (gensym)))
     241;          `(,%let* ((,sym ,(car args)) (it ,sym))
     242;                   ,(loop (cdr args) (append xpr (list sym)))))))))
     243
     244#|[
     245The following macro defines new macros masking property-accessors and
     246-mutators get and put!  For each supplied identifier, prop, another
     247identifier, prop!, is constructed behind the scene. The former will be
     248the accessor, the latter the mutator. So
     249  (prop sym)
     250is expands into
     251  (get sym 'prop)
     252and
     253  (prop! sym val)
     254into
     255  (put! sym 'prop val)
     256Note how the new names with the ! suffix are generated at compile time,
     257i.e. within an unquote. Note also the use of the injection argument, i, for
     258the property-name, prop, and the suffixed name, prop!, within that unquote.
     259]|#
     260
     261;;; (define-properties . names)
     262;;; ---------------------------
     263;;; defines, for each name, property-accessors and -mutators
     264;;; name and name!
     265(define-syntax define-properties
     266  (ir-macro-transformer
     267    (lambda (f i c?)
     268      `(begin
     269         ,@(map (lambda (prop)
     270                  `(begin
     271                     (define-syntax ,prop
     272                       (ir-macro-transformer
     273                         (lambda (form inject compare?)
     274                           `(get ,(cadr form) ',',prop))))
     275                     (define-syntax ,(i (string->symbol
     276                                          (string-append
     277                                            (symbol->string (i prop))
     278                                            "!")))
     279                       (ir-macro-transformer
     280                         (lambda (form inject compare?)
     281                           `(put! ,(cadr form)
     282                                  ',',prop
     283                                  ,(caddr form)))))))
     284                (cdr f))))))
     285
     286#|[
     287The following two macros and two procedures represent recursion an lists
     288and trees respectively. They are, again, inspired by Graham. The
     289procedures are defined with alambda, the anaphoric version of lambda
     290with injected symbol self.  These procedures, list-recurser and
     291tree-recurser,  accept a recurser and a base as arguments, the recurser
     292being itself procedures accepting the actual list or tree as argument,
     293as well as one or two thunks representing recursion along the cdr or the
     294car and the cdr respectively.
     295The macros, alist-recurser and atree-recurser, are anaphoric versions of
     296the procedures list-recurser and tree-recurser. They both inject the
     297symbol it behind the scene, representing the actual list or tree
     298respectively, as well as symbols go-on or go-left and go-right
     299respectively representing the recurser arguments of the functions.
     300
     301The relations between the procedures and the anaphoric macros are shown
     302in the following exaples:
     303  (define lcopy
     304    (list-recurser (lambda (lst th) (cons (car lst) (th))) '()))
     305  (define alcopy
     306    (alist-recurser (cons (car it) (go-on)) '()))
     307  (define tcopy
     308    (tree-recurser (lambda (tree left right)
     309                     (cons (left) (or (right) '())))
     310                   identity))
     311  (define atcopy
     312    (atree-recurser (cons (go-left) (or (go-right) '())) it))
     313]|#
     314
     315;;; (alist-recurser recurser base)
     316;;; ------------------------------
     317;;; wrapping list-recurser into an anaphoric macro with injected symbols it and go-on
     318;;; where it is the list itself and go-on the recurser-thunk
     319(define-syntax alist-recurser
     320  (ir-macro-transformer
     321    (lambda (form inject compare?)
     322      (let ((it (inject 'it))
     323            (go-on (inject 'go-on)))
     324        `(list-recurser (lambda (,it thunk)
     325                          (letrec ((,go-on thunk))
     326                            ,(cadr form)))
     327                        ,@(cddr form))))))
     328
     329;;; (atree-recurser recurser base)
     330;;; ------------------------------
     331;;; wrapping tree-recurser into an anaphoric macro with injected symbols
     332;;; it, go-left and go-right representing the actual tree and recursers
     333;;; along the car and the cdr respectively.
     334(define-syntax atree-recurser
     335  (ir-macro-transformer
     336    (lambda (form inject compare?)
     337      (let ((recurser (cadr form))
     338            (base (caddr form))
     339            (it (inject 'it))
     340            (go-left (inject 'go-left))
     341            (go-right (inject 'go-right)))
     342        `(tree-recurser
     343           (lambda (,it left right)
     344             (letrec ((,go-left left)
     345                      (,go-right right))
     346               ,recurser))
     347           (lambda (,it) ,base))))))
     348
     349;;; (list-recurser recurser base)
     350;;; -----------------------------
     351;;; recurser is a procedure of a list and a thunk processing the cdr
     352(define (list-recurser recurser base)
     353  (alambda (lst)
     354    (if (null? lst)
     355      (if (procedure? base)
     356        (base)
     357        base)
     358      (recurser lst
     359                (lambda ()
     360                  (self (cdr lst)))))))
     361
     362;;; (tree-recurser recurser base)
     363;;; -----------------------------
     364;;; recurser is a procedure of a tree and two thunks processing the car
     365;;; and the cdr
     366(define (tree-recurser recurser base)
     367  (alambda (tree)
     368    (cond
     369      ((pair? tree)
     370       (recurser tree
     371                 (lambda ()
     372                   (self (car tree)))
     373                 (lambda ()
     374                   (if (null? (cdr tree))
     375                     #f
     376                     (self (cdr tree))))))
     377      (else ; atom
     378        (if (procedure? base)
     379          (base tree)
     380          base)))))
     381
    157382;;; documentation dispatcher
    158383
     
    161386    (alist '(
    162387      (aif
    163         (aif test? consequent [alternative])
    164         "anaphoric if, consequent and alternative can refer to result it
    165 of test?")
     388        (macro it ()
     389          (aif consequent)
     390          (aif consequent alternative)))
    166391      (awhen
    167          (awhen test? xpr . xprs)
    168          "anaphoric when, where xpr ... can refer to result of test?
    169 named it")
     392        (macro it ()
     393          (awhen xpr . xprs)))
    170394      (acond
    171         (acond . clauses)
    172         "anaphoric cond, where each clause is a list (test? xpr ...) in which
    173 each xpr can refer to result of test? named it.
    174 The last clause can start with else which evaluates to #t.")
     395        (macro it ()
     396          (acond clauses)))
    175397      (awhile
    176         (awhile test? xpr . xprs)
    177         "anaphoric while, where each xpr ... can refer to the result of
    178 the successive test?, named it")
     398        (macro it ()
     399          (awhile xpr . xprs)))
    179400      (aand
    180         (aand . args)
    181         "anaporic and, each arg can refer to the previous arg with it")
     401        (macro it ()
     402          (aand args)))
    182403      (alambda
    183         (alambda args . body)
    184         "anaphoric lambda, where body can refer to self")
    185       )))
     404        (macro self ()
     405          (alambda . body)))
     406      (define-anaphor
     407        (macro ()
     408          (define-anaphor name from rule)))
     409      (define-properties
     410        (macro name! ... ()
     411          (define-properties name ...)))
     412      (list-recurser
     413        (procedure
     414          (list-recurser (lambda (lst thunk) ...)  base)))
     415      (alist-recurser
     416        (macro it go-on ()
     417          (alist-recurser recurser-xpr base-xpr)))
     418      (tree-recurser
     419        (procedure
     420          (tree-recurser (lambda (tree thunk0 thunk1) ...)  base)))
     421      (atree-recurser
     422        (macro it go-left go-right ()
     423          (atree-recurser recurser-xpr base-xpr)))))
     424    )
    186425    (case-lambda
    187426      (() (map car alist))
     
    189428       (let ((pair (assq sym alist)))
    190429         (if pair
    191            (cdr pair)
    192            (print "Choose one of " (map car alist))))))))
     430           (cadr pair)
     431           (begin
     432             (display "Choose one of ")
     433             (display (map car alist)))))))))
    193434
    194435) ; module anaphora
  • release/4/anaphora/trunk/anaphora.setup

    r25285 r29985  
    77 'anaphora
    88 '("anaphora.so" "anaphora.import.so")
    9  '((version "0.3.1")))
     9 '((version "0.4")))
    1010
    1111
  • release/4/anaphora/trunk/tests/run.scm

    r24376 r29985  
    1 ;;;; File: anaphora-run.scm
    2 ;;;; Author: Juergen Lorenz
    3 ;;;; ju (at) jugilo (dot) de
    4 ;;;; Date: Jun 20, 2011
     1(require-library anaphora simple-tests)
     2(import anaphora simple-tests)
    53
    6 
    7 (require 'anaphora)
    8 (import anaphora)
    9 
    10 (define run
    11   (lambda ()
    12     (if
    13       (and
    14         (equal?
    15           (aif (memv 3 '(1 2 3 4 5))
    16             it)
    17           '(3 4 5))
    18         (equal?
    19           (acond
    20             ((memv 6 '(1 2 3 4 5)) it)
    21             ((memv 3 '(1 2 3 4 5)) it)
    22             (else it))
    23           '(3 4 5))
    24         (eq?
    25           (acond
    26             ((memv 6 '(1 2 3 4 5)) it)
    27             (else it))
    28           #t)
    29         (eq?
    30           (acond
    31             ((memv 6 '(1 2 3 4 5)) it)
    32             (else #f))
    33           #f)
    34         (equal?
    35           (let ((lst '(1 2 3 4 5 #f)) (res '()))
    36             (awhile (car lst)
    37               (set! res (cons (car lst) res))
    38               (set! lst (cdr lst)))
    39             res)
    40         '(5 4 3 2 1))
    41         (equal?
    42           (awhen (memv 3 '(1 2 3 4 5)) it)
    43           '(3 4 5))
    44         (=
    45           (aand '(1 2 3 4 5) (cdr it) (car it))
    46           2)
    47         (equal?
    48           (map (alambda (n)
    49                  (if (zero? n)
    50                    1
    51                    (* n (self (- n 1)))))
    52                '(1 2 3 4 5))
    53           '(1 2 6 24 120)))
    54         (print "All tests passed")
    55         (print "##### Some tests failed #####"))))
    56 
    57 (run)
    58 
     4(compound-test ('ANAPHORA)
     5  (simple-test ('BASICS)
     6    (equal?
     7      (aif (memv 3 '(1 2 3 4 5))
     8        it)
     9      '(3 4 5))
     10    (equal?
     11      (acond
     12        ((memv 6 '(1 2 3 4 5)) it)
     13        ((memv 3 '(1 2 3 4 5)) it)
     14        (else it))
     15      '(3 4 5))
     16    (eq?
     17      (acond
     18        ((memv 6 '(1 2 3 4 5)) it)
     19        (else it))
     20      #t)
     21    (eq?
     22      (acond
     23        ((memv 6 '(1 2 3 4 5)) it)
     24        (else #f))
     25      #f)
     26    (equal?
     27      (let ((lst '(1 2 3 4 5 #f)) (res '()))
     28        (awhile (car lst)
     29          (set! res (cons (car lst) res))
     30          (set! lst (cdr lst)))
     31        res)
     32    '(5 4 3 2 1))
     33    (equal?
     34      (awhen (memv 3 '(1 2 3 4 5)) it)
     35      '(3 4 5))
     36    (=
     37      (aand '(1 2 3 4 5) (cdr it) (car it))
     38      2)
     39    (equal?
     40      (map (alambda (n)
     41             (if (zero? n)
     42               1
     43               (* n (self (- n 1)))))
     44           '(1 2 3 4 5))
     45      '(1 2 6 24 120)))
     46  (simple-test ('PROPERTIES)
     47    (define-properties color weight)
     48    (color! 'foo 'red)
     49    (eq? (color 'foo) 'red)
     50    (weight! 'foo 5)
     51    (= (weight 'foo) 5)
     52    (color! 'foo 'blue)
     53    (eq? (color 'foo) 'blue)
     54    (weight! 'foo 50)
     55    (= (weight 'foo) 50))
     56  (simple-test ('LIST-RECURSERS)
     57    (define llength
     58      (list-recurser (lambda (lst th) (add1 (th))) 0))
     59    (define allength
     60      (alist-recurser (add1 (go-on)) 0))
     61    (= (llength '(1 2 3)) 3)
     62    (= (allength '(1 2 3)) 3)
     63    (define (lsome? ok?)
     64      (list-recurser (lambda (lst th) (or (ok? (car lst)) (th))) #f))
     65    (define (alsome? ok?)
     66      (alist-recurser (or (ok? (car it)) (go-on)) #f))
     67    ((lsome? odd?) '(2 3 4))
     68    ((alsome? odd?) '(2 3 4))
     69    (define (alevery? ok?)
     70      (alist-recurser (and (ok? (car it)) (go-on)) #t))
     71    (not ((alevery? odd?) '(1 2 3)))
     72    (define (lfind ok?)
     73      (list-recurser (lambda (lst th) (if (ok? (car lst)) lst (th))) '()))
     74    (define (alfind ok?)
     75      (alist-recurser (if (ok? (car it)) it (go-on)) '()))
     76    (equal? ((lfind odd?) '(2 3 4)) '(3 4))
     77    (equal? ((alfind odd?) '(2 3 4)) '(3 4))
     78    (define lcopy
     79      (list-recurser (lambda (lst th) (cons (car lst) (th))) '()))
     80    (define alcopy
     81      (alist-recurser (cons (car it) (go-on)) '()))
     82    (equal? (lcopy '(1 2 3)) '(1 2 3))
     83    (equal? (alcopy '(1 2 3)) '(1 2 3))
     84    (define lremove-dups
     85      (list-recurser (lambda (lst th) (adjoin (car lst) (th))) '()))
     86    (define alremove-dups
     87      (alist-recurser (adjoin (car it) (go-on)) '()))
     88    (define (adjoin obj lst) (if (member obj lst) lst (cons obj lst)))
     89    (equal? (sort (lremove-dups '(1 2 1 3 2 4 3)) <) '(1 2 3 4))
     90    (equal? (sort (alremove-dups '(1 2 1 3 2 4 3)) <) '(1 2 3 4)))
     91  (simple-test ('TREE-RECURSERS)
     92    (define tflatten
     93      (tree-recurser (lambda (tree left right)
     94                       (append (left)
     95                               (or (right) '())))
     96                     (lambda (tree)
     97                       (if (list? tree) tree (list tree)))))
     98    (define atflatten
     99      (atree-recurser (append (go-left) (or (go-right) '()))
     100                      (if (list? it) it (list it))))
     101    (equal? (tflatten '(1 (2 3 (4)) 5)) '(1 2 3 4 5))
     102    (equal? (atflatten '(1 (2 3 (4)) 5)) '(1 2 3 4 5))
     103    (define tcopy
     104      (tree-recurser (lambda (tree left right)
     105                       (cons (left) (or (right) '())))
     106                     identity))
     107    (define atcopy
     108      (atree-recurser (cons (go-left) (or (go-right) '())) it))
     109    (equal? (tcopy '(1 (2 3 (4)) 5)) '(1 (2 3 (4)) 5))
     110    (equal? (atcopy '(1 (2 3 (4)) 5)) '(1 (2 3 (4)) 5))
     111    (define (tfind ok?)
     112      (tree-recurser (lambda (tree left right)
     113                       (or (left) (right)))
     114                     (lambda (tree)
     115                       (and (ok? tree) tree))))
     116    (define (atfind ok?)
     117      (atree-recurser (or (go-left) (go-right))
     118                      (and (ok? it) it)))
     119    (= ((tfind odd?) '(2 (4 5) 1)) 5)
     120    (= ((atfind odd?) '(2 (4 6) 1)) 1)
     121    (define tcount-leaves
     122      (tree-recurser (lambda (tree left right)
     123                       (+ (left) (or (right) 1)))
     124                     1))
     125    (define atcount-leaves
     126      (atree-recurser (+ (go-left) (or (go-right) 1)) 1))
     127    (= (tcount-leaves '((1 2 (3 4)) (5) 6)) 10)
     128    (= (atcount-leaves '((1 2 (3 4)) (5) 6)) 10))
     129  (simple-test ('DEFINE-ANAPHOR)
     130    (define-anaphor alist list #:cascade)
     131    (define-anaphor a+ + #:cascade)
     132    (define-anaphor a- - #:cascade)
     133    (equal? (alist 1 (+ it 2) (* it 3)) '(1 3 9))
     134    (= (a+ 1 (+ it 2) (* it 3)) 13)
     135    (= (a- 1 (+ it 2) (* it 3)) -11)
     136    (define-anaphor aand and #:cascade)
     137    (equal? (aand (list 1 2 3) (cdr it) (cdr it)) '(3))
     138    (define-anaphor awhen when #:first)
     139    (= (awhen (* 1 2 3 4 5) (* 2 it)) 240))
     140)
Note: See TracChangeset for help on using the changeset viewer.