Changeset 30179 in project


Ignore:
Timestamp:
12/11/13 18:17:18 (8 years ago)
Author:
juergen
Message:

anaphora 0.4 with hygienic named macros

Location:
release/4/anaphora/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/anaphora/trunk/anaphora.meta

    r29985 r30179  
    11;;;; anaphora.meta -*- Scheme -*-
    22
    3 ((synopsis "Unhygienic anaphoric macros")
     3((synopsis "Unhygienic anaphoric macros and hygienic named macros")
    44 (category lang-exts)
    55 (license "BSD")
  • release/4/anaphora/trunk/anaphora.scm

    r29985 r30179  
    22; ju (at) jugilo (dot) de
    33;
    4 ; Last update: Sep 08, 2011
    5 ;
    6 ; Copyright (c) 2011, Juergen Lorenz
     4; Copyright (c) 2011-2013, Juergen Lorenz
    75; All rights reserved.
    86;
     
    3432; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
    3533;
    36 
    37 
     34; Last update: Dec 11, 2013
     35;
     36#|[
    3837;Inspired by Paul Graham's classic "On Lisp" this module introduces
    3938;anaphoric macros, which are unhygienic by design. Hence they can not be
     
    4241;without being declared. Please note, that this identifier is not
    4342;renamed!
     43]|#
    4444
    4545(module anaphora
    4646
    47 (export anaphora aif awhen acond awhile aand alambda define-anaphor
     47(export anaphora
     48        aif nif
     49        alambda nlambda
     50        awhen nwhen
     51        acond ncond
     52        awhile nwhile
     53        aand nand
     54        define-anaphor
    4855        define-properties alist-recurser atree-recurser
    4956        tree-recurser list-recurser)
    50 (import scheme (only chicken case-lambda gensym print)) ;;print
     57(import scheme (only chicken case-lambda gensym))
    5158
    5259;;; (aif test consequent [alternative])
    53 ;;; ------------------------------------
     60;;; -----------------------------------
    5461;;; anaphoric if, where consequent and alternative can refer to result
    5562;;; of test named it
     
    6976               (if ,it ,consequent ,(car alternative)))))))))
    7077
     78;;; (nif name test consequent [alternative])
     79;;; ----------------------------------------
     80;;; named if, where consequent and alternative can refer to result
     81;;; of test named name
     82(define-syntax nif
     83  (syntax-rules ()
     84    ((_ name test consequent)
     85     (let ((name test))
     86       (if name consequent)))
     87    ((_ name test consequent alternative)
     88     (let ((name test))
     89       (if name consequent alternative)))))
     90
    7191;;; (awhen test xpr . xprs)
    72 ;;; ------------------------
     92;;; -----------------------
    7393;;; anaphoric when, where xpr ... can refer to result of test
    7494;;; named it
     
    85105             (if ,it (begin ,xpr ,@xprs))))))))
    86106
    87 ;;; (acond . clauses)
    88 ;;; -----------------
    89 ;;; anaphoric cond, where each clause is a list (test xpr ...) in which
    90 ;;; each xpr can refer to result of test named it.
    91 ;;; The last clause can start with else which evaluates to #t.
     107;;; (nwhen name test xpr . xprs)
     108;;; ----------------------------
     109;;; named when, where xpr ... can refer to result of test
     110;;; named name
     111(define-syntax nwhen
     112  (syntax-rules ()
     113    ((_ name test xpr . xprs)
     114     (let ((name test))
     115       (if name (begin xpr . xprs))))))
     116
     117;;; (acond (test xpr ...) ... [(else ypr ...)])
     118;;; -------------------------------------------
     119;;; anaphoric cond, where each test is bound to it and else to #t.
    92120(define-syntax acond
    93121  (ir-macro-transformer
     
    108136                     ,(loop (cdr clauses))))))))))))
    109137
     138;;; (ncond name (test xpr ...) ... [(else ypr ...)])
     139;;; ------------------------------------------------
     140;;; anaphoric cond, where each test is bound to name and else to #t.
     141(define-syntax ncond
     142  (syntax-rules (else)
     143    ((_ name) #f)
     144    ((_ name (else xpr . xprs) . clauses)
     145     (let ((sym #t))
     146       (if sym
     147         (let ((name sym)) xpr . xprs)
     148         #f)))
     149    ((_ name (test xpr . xprs) . clauses)
     150     (let ((sym test))
     151       (if sym
     152         (let ((name sym)) xpr . xprs)
     153         (ncond name . clauses))))))
     154
    110155;;; (awhile test xpr . xprs)
    111 ;;; -------------------------
     156;;; ------------------------
    112157;;; anaphoric while, where each xpr ... can refer to the result of
    113158;;; the successive test, named it
     
    126171               (loop ,test))))))))
    127172
     173;;; (nwhile name test xpr . xprs)
     174;;; -----------------------------
     175;;; named while, where each xpr ... can refer to the result of
     176;;; the successive test, named name
     177(define-syntax nwhile
     178  (syntax-rules ()
     179    ((_ name test xpr . xprs)
     180     (let loop ((name test))
     181       (when name
     182         (begin xpr . xprs)
     183         (loop test))))))
     184
    128185;;; (aand . args)
    129186;;; -------------
     
    144201                     ,(loop (cdr args))))))))))))
    145202
     203;;; (nand name . args)
     204;;; ------------------
     205;;; named and, where each successive argument can refer to the
     206;;; result of the previous argument, named name.
     207(define-syntax nand
     208  (syntax-rules ()
     209    ((_ name) #t)
     210    ((_ name arg) arg)
     211    ((_ name arg0 arg1 ...)
     212     (let ((name arg0))
     213       (if name (nand name arg1 ...))))))
     214
    146215;;; (alambda args xpr . xprs)
    147216;;; -------------------------
     
    155224          `(letrec ((,self (lambda ,args ,@body)))
    156225             ,self))))))
     226
     227;;; (nlambda name args xpr . xprs)
     228;;; ------------------------------
     229;;; named lambda, where the body xpr ... can refer to name, so that
     230;;; recursion is possible
     231(define-syntax nlambda
     232  (syntax-rules ()
     233    ((_ name args xpr . xprs)
     234     (letrec ((name (lambda args xpr . xprs)))
     235       name))))
    157236
    158237#|[
     
    386465    (alist '(
    387466      (aif
    388         (macro it ()
    389           (aif consequent)
    390           (aif consequent alternative)))
     467"anaphoric if where result of test is named it"
     468        (aif test consequent [alternative]))
     469      (nif
     470"named if where result of test is named name"
     471        (nif name test consequent [alternative]))
    391472      (awhen
    392         (macro it ()
    393           (awhen xpr . xprs)))
     473"anaphoric when where result of test is named it"
     474         (awhen test xpr . xprs))
     475      (nwhen
     476"named when where result of test is named name"
     477         (nwhen name test xpr . xprs))
    394478      (acond
    395         (macro it ()
    396           (acond clauses)))
     479"anaphoric cond, where each test except else is named it"
     480        (acond (test xpr . xprs) ... [(else xpr . xprs)]))
     481      (ncond
     482"named cond, where each test except else is named name"
     483        (ncond name (test xpr . xprs) ... [(else xpr . xprs)]))
    397484      (awhile
    398         (macro it ()
    399           (awhile xpr . xprs)))
     485"anaphoric while, where each successive test is named it"
     486        (awhile test xpr . xprs))
     487      (nwhile
     488"named while, where each successive test is named name"
     489        (nwhile name test xpr . xprs))
    400490      (aand
    401         (macro it ()
    402           (aand args)))
     491"anaporic and, where each arg can refer to the previous arg named it"
     492        (aand . args))
     493      (nand
     494"named and, where each arg can refer to the previous arg named name"
     495        (nand name . args))
    403496      (alambda
    404         (macro self ()
    405           (alambda . body)))
     497"anaphoric lambda, where body can refer to self"
     498        (alambda args . body))
     499      (nlambda
     500"named lambda, where body can refer to name"
     501        (nlambda name args . body))
    406502      (define-anaphor
    407         (macro ()
    408           (define-anaphor name from rule)))
     503"define an anaphoric macro from a routine with implicit it and rule cascade: or first:"
     504        (define-anaphor name from rule))
    409505      (define-properties
    410         (macro name! ... ()
    411           (define-properties name ...)))
     506"abstracting away get and put! Defines properties name and name! ..."
     507        (define-properties name ...))
     508      (alist-recurser
     509"creates unary procedure from macro-arguments with implicit it and go-on thunk"
     510        (alist-recurser recur-xpr base-xpr))
     511      (atree-recurser
     512"creates unary procedure from macro-arguments with implicit it, go-left and go-right thunks"
     513        (alist-recurser recur-xpr base-xpr))
    412514      (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)))
     515"creates procedure which traverses on cdrs of its only argument"
     516        (list-recurser recurser base))
    418517      (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     )
     518"creates procedure which traverses on cars and cdrs of its only argument"
     519        (tree-recurser recurser base))
     520      )))
    425521    (case-lambda
    426522      (() (map car alist))
     
    428524       (let ((pair (assq sym alist)))
    429525         (if pair
    430            (cadr pair)
     526           (cdr pair)
    431527           (begin
    432528             (display "Choose one of ")
    433              (display (map car alist)))))))))
     529             (display (map car alist))
     530             (newline))))))))
     531
    434532
    435533) ; module anaphora
  • release/4/anaphora/trunk/tests/run.scm

    r29985 r30179  
    99      '(3 4 5))
    1010    (equal?
     11      (nif it (memv 3 '(1 2 3 4 5))
     12        it)
     13      '(3 4 5))
     14
     15    (equal?
    1116      (acond
     17        ((memv 6 '(1 2 3 4 5)) it)
     18        ((memv 3 '(1 2 3 4 5)) it)
     19        (else it))
     20      '(3 4 5))
     21    (equal?
     22      (ncond it
    1223        ((memv 6 '(1 2 3 4 5)) it)
    1324        ((memv 3 '(1 2 3 4 5)) it)
     
    2031      #t)
    2132    (eq?
    22       (acond
     33      (ncond it
    2334        ((memv 6 '(1 2 3 4 5)) it)
    24         (else #f))
    25       #f)
     35        (else it))
     36      #t)
     37   
    2638    (equal?
    2739      (let ((lst '(1 2 3 4 5 #f)) (res '()))
     
    3244    '(5 4 3 2 1))
    3345    (equal?
     46      (let ((lst '(1 2 3 4 5 #f)) (res '()))
     47        (nwhile it (car lst)
     48          (set! res (cons (car lst) res))
     49          (set! lst (cdr lst)))
     50        res)
     51    '(5 4 3 2 1))
     52
     53    (equal?
    3454      (awhen (memv 3 '(1 2 3 4 5)) it)
    3555      '(3 4 5))
     56    (equal?
     57      (nwhen it (memv 3 '(1 2 3 4 5)) it)
     58      '(3 4 5))
     59
    3660    (=
    3761      (aand '(1 2 3 4 5) (cdr it) (car it))
    3862      2)
     63    (=
     64      (nand it '(1 2 3 4 5) (cdr it) (cdr it) (car it))
     65      3)
     66
    3967    (equal?
    4068      (map (alambda (n)
     
    4371               (* n (self (- n 1)))))
    4472           '(1 2 3 4 5))
     73      '(1 2 6 24 120))
     74    (equal?
     75      (map (nlambda self (n)
     76             (if (zero? n)
     77               1
     78               (* n (self (- n 1)))))
     79           '(1 2 3 4 5))
    4580      '(1 2 6 24 120)))
     81
    4682  (simple-test ('PROPERTIES)
    4783    (define-properties color weight)
Note: See TracChangeset for help on using the changeset viewer.