Changeset 4641 in project


Ignore:
Timestamp:
06/24/07 03:58:56 (13 years ago)
Author:
Jim Ursetto
Message:

syntactic-closures: hygienify cond-expand, include; export syntax-case, syntax-match?

Files:
4 edited

Legend:

Unmodified
Added
Removed
  • syntactic-closures/syntactic-closures-chicken-macros.scm

    r4598 r4641  
    1515          (apply expander (cdr exp)) ) ) ) ) ) )
    1616
    17 (define-macro (cond-expand . clauses)
    18   (define (err x)
    19     (syntax-error "syntax error in `cond-expand' form" x (cons 'cond-expand clauses)) )
    20   (define (test fx)
    21     (cond ((symbol? fx) (##sys#feature? fx))
    22           ((not (pair? fx)) (err fx))
    23           (else
    24            (let ((rest (##sys#slot fx 1)))
    25              (case (##sys#slot fx 0)
    26                ((and)
    27                 (or (eq? rest '())
    28                     (if (pair? rest)
    29                         (and (test (##sys#slot rest 0))
    30                              (test `(and ,@(##sys#slot rest 1))) )
    31                         (err fx) ) ) )
    32                ((or)
    33                 (and (not (eq? rest '()))
    34                      (if (pair? rest)
    35                          (or (test (##sys#slot rest 0))
    36                              (test `(or ,@(##sys#slot rest 1))) )
    37                          (err fx) ) ) )
    38                ((not) (not (test (cadr fx))))
    39                (else (err fx)) ) ) ) ) )
    40   (let expand ((cls clauses))
    41     (cond ((eq? cls '())
    42            (##sys#apply
    43             ##sys#error "no matching clause in `cond-expand' form"
    44             (map (lambda (x) (car x)) clauses) ) )
    45           ((not (pair? cls)) (err cls))
    46           (else
    47            (let ((clause (##sys#slot cls 0))
    48                  (rclauses (##sys#slot cls 1)) )
    49              (if (not (pair? clause))
    50                  (err clause)
    51                  (let ((id (##sys#slot clause 0)))
    52                    (cond ((eq? id 'else)
    53                           (let ((rest (##sys#slot clause 1)))
    54                             (if (eq? rest '())
    55                                 '(##core#undefined)
    56                                 `(begin ,@rest) ) ) )
    57                          ((test id) `(begin ,@(##sys#slot clause 1)))
    58                          (else (expand rclauses)) ) ) ) ) ) ) ) )
    59 
    60 (define-macro (include filename)
    61   (let ((path (##sys#resolve-include-filename filename #t)))
    62     (when (load-verbose) (print "; including " path " ..."))
    63     `(begin
    64        ,@(with-input-from-file path
    65            (lambda ()
    66              (do ([x (read) (read)]
    67                   [xs '() (cons x xs)] )
    68                  ((eof-object? x)
    69                   (reverse xs))) ) ) ) ) )
     17(define-syntax cond-expand
     18  (sc-macro-transformer
     19   (lambda (form env)
     20     (capture-syntactic-environment
     21      (lambda (transformer-env)
     22       
     23        (define (err x)
     24          (syntax-error "syntax error in `cond-expand' form" x form))
     25        (define (literal=? usage-id transformer-id)
     26          (and (identifier? usage-id)
     27               (identifier=? env usage-id transformer-env transformer-id)))
     28        (define (close-forms forms)
     29          (map (lambda (form) (make-syntactic-closure env '() form)) forms))
     30        (define (test fx)
     31          (cond ((identifier? fx)
     32                 (and (identifier=? env fx transformer-env fx)
     33                      (##sys#feature? fx)))
     34                ((not (pair? fx)) (err fx))
     35                (else
     36                 (let ((bool (##sys#slot fx 0))
     37                       (rest (##sys#slot fx 1)))
     38                   (if (literal=? bool bool)
     39                       (case bool
     40                         ((and)
     41                          (or (eq? rest '())
     42                              (if (pair? rest)
     43                                  (and (test (##sys#slot rest 0))
     44                                       (test `(and ,@(##sys#slot rest 1))) )
     45                                  (err fx) ) ) )
     46                         ((or)
     47                          (and (not (eq? rest '()))
     48                               (if (pair? rest)
     49                                   (or (test (##sys#slot rest 0))
     50                                       (test `(or ,@(##sys#slot rest 1))) )
     51                                   (err fx) ) ) )
     52                         ((not) (not (test (cadr fx))))
     53                         (else (err fx)))
     54                       (err fx)) ))))
     55
     56        (let ((clauses (cdr form)))
     57          (let expand ((cls clauses))
     58            (cond ((null? cls)
     59                   (##sys#apply
     60                    ##sys#error "no matching clause in `cond-expand' form"
     61                    (map car clauses) ) )
     62                  ((not (pair? cls)) (err cls))
     63                  (else
     64                   (let ((clause (##sys#slot cls 0))
     65                         (rclauses (##sys#slot cls 1)) )
     66                     (if (not (pair? clause))
     67                         (err clause)
     68                         (let ((id (##sys#slot clause 0)))
     69                           (cond ((literal=? id 'else)
     70                                  (let ((rest (##sys#slot clause 1)))
     71                                    (if (null? rest)
     72                                        '(##core#undefined)
     73                                        `(begin ,@(close-forms rest)) ) ) )
     74                                 ((test id) `(begin ,@(close-forms
     75                                                       (##sys#slot clause 1))))
     76                                 (else (expand rclauses)) ) ) ) ) ) ) ) ) ) ) ) ) )
     77
     78(define-syntax include
     79  (rsc-macro-transformer
     80   (lambda (exp env)
     81     (syntax-check '(keyword expression) exp)
     82     (let ((filename (cadr exp)))
     83       (let ((path (##sys#resolve-include-filename filename #t)))
     84         (when (load-verbose) (print "; including " path " ..."))
     85         `(,(make-syntactic-closure env '() 'begin)
     86           ,@(with-input-from-file path
     87               (lambda ()
     88                 (do ([x (read) (read)]
     89                      [xs '() (cons x xs)] )
     90                     ((eof-object? x)
     91                      (reverse xs))) ) ) ) ) ))))
    7092 
    7193(define-syntax receive
  • syntactic-closures/syntactic-closures.scm

    r4634 r4641  
    3838          identifier? identifier=?
    3939          scheme-syntactic-environment macroexpand
     40          syntax-match? syntax-check
    4041          ##sys#compiler-toplevel-macroexpand-hook
    4142          ##sys#interpreter-toplevel-macroexpand-hook) )
  • syntactic-closures/syntactic-closures.setup

    r4634 r4641  
    33 'syntactic-closures
    44 '("syntactic-closures.so" "syntactic-closures.html" "syntactic-closures-chicken-macros.scm")
    5  '((version 0.983)
     5 '((version 0.984)
    66   (documentation "syntactic-closures.html")
    77   (syntax) ) )
  • wiki/syntactic-closures

    r4636 r4641  
    428428=== History
    429429
     430; 0.984 : hygienify {{cond-expand}}, {{include}}; export {{syntax-case}}, {{syntax-match?}} (zbigniew)
    430431; 0.983 : added curried {{define}} (zbigniew)
    431432; 0.982 : added {{rsc-macro-transformer}}; {{define-macro}} now non-hygienic (zbigniew)
Note: See TracChangeset for help on using the changeset viewer.