Changeset 7839 in project


Ignore:
Timestamp:
01/22/08 09:36:51 (12 years ago)
Author:
felix winkelmann
Message:

updated bootstrap tarball, cond-expand is available to base expander

Location:
chicken/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/NEWS

    r7775 r7839  
    88- added csi options "-p" ("-print") and "-P" ("-pretty-print")
    99- support for Mac OS X universal binaries hase been added [Thanks to Zbigniew]
     10- `cond-expand' is available in the set of core macros [Thanks to Alex Shinn]
     11- On sparc64 architectures more than 126 procedure arguments are allowed
     12  [Thanks to Peter Bex]
    1013
    11142.739
  • chicken/trunk/chicken-more-macros.scm

    r6839 r7839  
    383383                            `(let ((,var ,(cadr b)))
    384384                               (if ,var ,(fold bs2) #f) ) ) ] ) ) ) ) ) ) ) )
    385 
    386 (##sys#register-macro-2
    387  'cond-expand
    388    (lambda (clauses)
    389 
    390      (define (err x)
    391        (##sys#error "syntax error in `cond-expand' form" x (cons 'cond-expand clauses)) )
    392 
    393      (define (test fx)
    394        (cond ((symbol? fx) (##sys#feature? fx))
    395              ((not (pair? fx)) (err fx))
    396              (else
    397               (let ((rest (##sys#slot fx 1)))
    398                 (case (##sys#slot fx 0)
    399                   ((and)
    400                    (or (eq? rest '())
    401                        (if (pair? rest)
    402                            (and (test (##sys#slot rest 0))
    403                                 (test `(and ,@(##sys#slot rest 1))) )
    404                            (err fx) ) ) )
    405                   ((or)
    406                    (and (not (eq? rest '()))
    407                         (if (pair? rest)
    408                             (or (test (##sys#slot rest 0))
    409                                 (test `(or ,@(##sys#slot rest 1))) )
    410                             (err fx) ) ) )
    411                   ((not) (not (test (cadr fx))))
    412                   (else (err fx)) ) ) ) ) )
    413 
    414      (let expand ((cls clauses))
    415        (cond ((eq? cls '())
    416               (##sys#apply
    417                ##sys#error "no matching clause in `cond-expand' form"
    418                (map (lambda (x) (car x)) clauses) ) )
    419              ((not (pair? cls)) (err cls))
    420              (else
    421               (let ((clause (##sys#slot cls 0))
    422                     (rclauses (##sys#slot cls 1)) )
    423                 (if (not (pair? clause))
    424                     (err clause)
    425                     (let ((id (##sys#slot clause 0)))
    426                       (cond ((eq? id 'else)
    427                              (let ((rest (##sys#slot clause 1)))
    428                                (if (eq? rest '())
    429                                    '(##core#undefined)
    430                                    `(begin ,@rest) ) ) )
    431                             ((test id) `(begin ,@(##sys#slot clause 1)))
    432                             (else (expand rclauses)) ) ) ) ) ) ) ) ) )
    433385
    434386(##sys#register-macro-2
  • chicken/trunk/eval.scm

    r7180 r7839  
    20212021 (lambda (x) `(##sys#make-promise (lambda () ,x))) )
    20222022
     2023(##sys#register-macro-2
     2024 'cond-expand
     2025   (lambda (clauses)
     2026
     2027     (define (err x)
     2028       (##sys#error "syntax error in `cond-expand' form" x (cons 'cond-expand clauses)) )
     2029
     2030     (define (test fx)
     2031       (cond ((symbol? fx) (##sys#feature? fx))
     2032             ((not (pair? fx)) (err fx))
     2033             (else
     2034              (let ((rest (##sys#slot fx 1)))
     2035                (case (##sys#slot fx 0)
     2036                  ((and)
     2037                   (or (eq? rest '())
     2038                       (if (pair? rest)
     2039                           (and (test (##sys#slot rest 0))
     2040                                (test `(and ,@(##sys#slot rest 1))) )
     2041                           (err fx) ) ) )
     2042                  ((or)
     2043                   (and (not (eq? rest '()))
     2044                        (if (pair? rest)
     2045                            (or (test (##sys#slot rest 0))
     2046                                (test `(or ,@(##sys#slot rest 1))) )
     2047                            (err fx) ) ) )
     2048                  ((not) (not (test (cadr fx))))
     2049                  (else (err fx)) ) ) ) ) )
     2050
     2051     (let expand ((cls clauses))
     2052       (cond ((eq? cls '())
     2053              (##sys#apply
     2054               ##sys#error "no matching clause in `cond-expand' form"
     2055               (map (lambda (x) (car x)) clauses) ) )
     2056             ((not (pair? cls)) (err cls))
     2057             (else
     2058              (let ((clause (##sys#slot cls 0))
     2059                    (rclauses (##sys#slot cls 1)) )
     2060                (if (not (pair? clause))
     2061                    (err clause)
     2062                    (let ((id (##sys#slot clause 0)))
     2063                      (cond ((eq? id 'else)
     2064                             (let ((rest (##sys#slot clause 1)))
     2065                               (if (eq? rest '())
     2066                                   '(##core#undefined)
     2067                                   `(begin ,@rest) ) ) )
     2068                            ((test id) `(begin ,@(##sys#slot clause 1)))
     2069                            (else (expand rclauses)) ) ) ) ) ) ) ) ) )
     2070
    20232071
    20242072;;; SRFI-0 support code:
Note: See TracChangeset for help on using the changeset viewer.