Changeset 9711 in project


Ignore:
Timestamp:
03/15/08 07:47:53 (11 years ago)
Author:
ashinn
Message:

Fixing vector template outputs that contain pattern variables in
syntax-rules.

Location:
release/3/syntactic-closures
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/3/syntactic-closures/syntactic-closures.scm

    r5660 r9711  
    14201420  (letrec
    14211421      ((loop
    1422         (lambda (pattern expression)
    1423           (cond ((identifier? pattern)
    1424                  (if (memq pattern keywords)
    1425                      (let ((temp (rename 'temp)))
    1426                        `((,(rename 'lambda)
    1427                           (,temp)
    1428                           (,(rename 'if)
    1429                            (,(rename 'identifier?) ,temp)
    1430                            (,r-compare ,temp
    1431                                        (,r-rename ,(syntax-quote pattern)))
    1432                            #f))
    1433                          ,expression))
    1434                      `#t))
    1435                 ((and (zero-or-more? pattern rename compare)
    1436                       (null? (cddr pattern)))
    1437                  (do-list (car pattern) expression))
    1438                 ((and (at-least-one? pattern rename compare)
    1439                       (null? (cddr pattern)))
    1440                  `(,(rename 'if) (,(rename 'null?) ,expression)
    1441                                  #f
    1442                                  ,(do-list (car pattern) expression)))
    1443                 ((pair? pattern)
    1444                  (let ((generate-pair
    1445                         (lambda (expression)
    1446                           (conjunction
    1447                            `(,(rename 'pair?) ,expression)
    1448                            (conjunction
    1449                             (loop (car pattern)
    1450                                   `(,(rename 'car) ,expression))
    1451                             (loop (cdr pattern)
    1452                                   `(,(rename 'cdr) ,expression)))))))
    1453                    (if (identifier? expression)
    1454                        (generate-pair expression)
    1455                        (let ((temp (rename 'temp)))
    1456                          `((,(rename 'lambda) (,temp) ,(generate-pair temp))
    1457                            ,expression)))))
    1458                 ((null? pattern)
    1459                  `(,(rename 'null?) ,expression))
    1460                 ((vector? pattern)
    1461                  (letrec
    1462                      ((len (vector-length pattern))
    1463                       (generate-vector
    1464                        (lambda (len res)
    1465                          (if (negative? len)
    1466                            res
    1467                            (generate-vector
    1468                             (- len 1)
    1469                             (conjunction (loop (vector-ref pattern len)
    1470                                                `(,(rename 'vector-ref)
    1471                                                  ,expression
    1472                                                  ,len))
    1473                                          res))))))
    1474                    (if (zero? len)
    1475                      `(,(rename 'equal?) ,expression '#())
    1476                      (conjunction
    1477                       `(,(rename 'vector?) ,expression)
    1478                       (if (compare (vector-ref pattern (- len 1)) (rename '...))
     1422           (lambda (pattern expression)
     1423             (cond ((identifier? pattern)
     1424                    (if (memq pattern keywords)
     1425                        (let ((temp (rename 'temp)))
     1426                          `((,(rename 'lambda)
     1427                             (,temp)
     1428                             (,(rename 'if)
     1429                              (,(rename 'identifier?) ,temp)
     1430                              (,r-compare ,temp
     1431                                          (,r-rename ,(syntax-quote pattern)))
     1432                              #f))
     1433                            ,expression))
     1434                        `#t))
     1435                   ((and (zero-or-more? pattern rename compare)
     1436                         (null? (cddr pattern)))
     1437                    (do-list (car pattern) expression))
     1438                   ((and (at-least-one? pattern rename compare)
     1439                         (null? (cddr pattern)))
     1440                    `(,(rename 'if) (,(rename 'null?) ,expression)
     1441                      #f
     1442                      ,(do-list (car pattern) expression)))
     1443                   ((pair? pattern)
     1444                    (let ((generate-pair
     1445                           (lambda (expression)
     1446                             (conjunction
     1447                              `(,(rename 'pair?) ,expression)
     1448                              (conjunction
     1449                               (loop (car pattern)
     1450                                 `(,(rename 'car) ,expression))
     1451                               (loop (cdr pattern)
     1452                                 `(,(rename 'cdr) ,expression)))))))
     1453                      (if (identifier? expression)
     1454                          (generate-pair expression)
     1455                          (let ((temp (rename 'temp)))
     1456                            `((,(rename 'lambda) (,temp) ,(generate-pair temp))
     1457                              ,expression)))))
     1458                   ((null? pattern)
     1459                    `(,(rename 'null?) ,expression))
     1460                   ;; just revert to this if you have problems with
     1461                   ;; the optimized code below
     1462                   ;;((vector? pattern)
     1463                   ;; (conjunction `(,(rename 'vector?) ,expression)
     1464                   ;;               (loop (vector->list pattern) `(,(rename 'vector->list) ,expression))))
     1465                   ((vector? pattern)
     1466                    (letrec
     1467                        ((len (vector-length pattern))
     1468                         (generate-vector
     1469                          (lambda (i res)
     1470                            (if (negative? i)
     1471                                res
     1472                                (generate-vector
     1473                                 (- i 1)
     1474                                 (conjunction (loop (vector-ref pattern i)
     1475                                                `(,(rename 'vector-ref)
     1476                                                  ,expression
     1477                                                  ,i))
     1478                                              res))))))
     1479                      (cond
     1480                       ((zero? len)
     1481                        `(,(rename 'equal?) ,expression '#()))
     1482                       ((and (= len 2)
     1483                             (compare (vector-ref pattern 1)
     1484                                      (rename '...))
     1485                             (identifier? (vector-ref pattern 0)))
     1486                        ;; shortcut for the #(a ...) pattern
     1487                        `(,(rename 'vector?) ,expression))
     1488                       (else
    14791489                        (conjunction
    1480                          `(,(rename '>=)
    1481                            (,(rename 'vector-length) ,expression)
    1482                            ,(- len 2))
    1483                          (conjunction
    1484                           (generate-vector (- len 2) #t)
    1485                           (do-vec (vector-ref pattern (- len 1))
    1486                                   expression
    1487                                   (- len 1))))
    1488                         (conjunction
    1489                          `(,(rename '>=)
    1490                            (,(rename 'vector-length) ,expression)
    1491                            ,(- len 2))
    1492                          (generate-vector (- len 1) #t)))))))
    1493                 (else
    1494                  `(,(rename 'equal?) ,expression
    1495                                      (,(rename 'quote) ,pattern))))))
     1490                         `(,(rename 'vector?) ,expression)
     1491                         (if (compare (vector-ref pattern (- len 1))
     1492                                      (rename '...))
     1493                             (conjunction
     1494                              `(,(rename '>=)
     1495                                (,(rename 'vector-length) ,expression)
     1496                                ,(- len 2))
     1497                              (conjunction
     1498                               (generate-vector (- len 2) #t)
     1499                               (do-vec (vector-ref pattern (- len 2))
     1500                                       expression
     1501                                       (- len 2))))
     1502                             (conjunction
     1503                              `(,(rename '=)
     1504                                (,(rename 'vector-length) ,expression)
     1505                                ,len)
     1506                              (generate-vector (- len 1) #t))))))))
     1507                   (else
     1508                    `(,(rename 'equal?) ,expression
     1509                      (,(rename 'quote) ,pattern))))))
    14961510       (do-list
    14971511        (lambda (pattern expression)
     
    15791593                           (loop (car template) ellipses)
    15801594                           (loop (cdr template) ellipses)))
     1595          ((vector? template)
     1596           `(,(rename 'list->vector) ,(loop (vector->list template) ellipses)))
    15811597          (else
    15821598           `(,(rename 'quote) ,template)))))
  • release/3/syntactic-closures/syntactic-closures.setup

    r6639 r9711  
    44 'syntactic-closures
    55 '("syntactic-closures.so" "syntactic-closures.html" "syntactic-closures-chicken-macros.scm")
    6  '((version 0.987)
     6 '((version 0.988)
    77   (documentation "syntactic-closures.html")
    88   (syntax) ) )
Note: See TracChangeset for help on using the changeset viewer.